diff --git a/Language/Haskell/Liquid/ACSS.hs b/Language/Haskell/Liquid/ACSS.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/ACSS.hs +++ /dev/null @@ -1,287 +0,0 @@ --- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations -module Language.Haskell.Liquid.ACSS ( - hscolour - , hsannot - , AnnMap (..) - , breakS - , srcModuleName - , Status (..) - ) where - -import Language.Haskell.HsColour.Anchors -import Language.Haskell.HsColour.Classify as Classify -import Language.Haskell.HsColour.HTML (renderAnchors, escape) -import qualified Language.Haskell.HsColour.CSS as CSS - -import Data.Either (partitionEithers) -import Data.Maybe (fromMaybe) -import qualified Data.HashMap.Strict as M -import Data.List (find, isPrefixOf, findIndex, elemIndices, intercalate) -import Data.Char (isSpace) -import Text.Printf -import Language.Haskell.Liquid.GhcMisc --- import Language.Fixpoint.Misc --- import Data.Monoid - - --- import Debug.Trace - -data AnnMap = Ann { - types :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type) - , errors :: [(Loc, Loc, String)] -- ^ List of error intervals - , status :: !Status - } - -data Status = Safe | Unsafe | Error | Crash - deriving (Eq, Ord, Show) - -emptyAnnMap = Ann M.empty [] - -data Annotation = A { - typ :: Maybe String -- ^ type string - , err :: Maybe String -- ^ error string - , lin :: Maybe (Int, Int) -- ^ line number, total width of lines i.e. max (length (show lineNum)) - } deriving (Show) - -getFirstMaybe x@(Just _) _ = x -getFirstMaybe Nothing y = y - - --- | Formats Haskell source code using HTML and mouse-over annotations -hscolour :: Bool -- ^ Whether to include anchors. - -> Bool -- ^ Whether input document is literate haskell or not - -> String -- ^ Haskell source code, Annotations as comments at end - -> String -- ^ Coloured Haskell source code. - -hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns - -type CommentTransform = Maybe (String -> [(TokenType, String)]) - --- | Formats Haskell source code using HTML and mouse-over annotations -hsannot :: Bool -- ^ Whether to include anchors. - -> CommentTransform -- ^ Function to refine comment tokens - -> Bool -- ^ Whether input document is literate haskell or not - -> (String, AnnMap) -- ^ Haskell Source, Annotations - -> String -- ^ Coloured Haskell source code. - -hsannot anchor tx False z = hsannot' Nothing anchor tx z -hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s - where chunk (Code c, l) = hsannot' (Just l) anchor tx (c, m) - chunk (Lit c , _) = c - -litSpans :: [Lit] -> [(Lit, Loc)] -litSpans lits = zip lits $ spans lits - where spans = tokenSpans Nothing . map unL - -hsannot' baseLoc anchor tx = - CSS.pre - . (if anchor then concatMap (renderAnchors renderAnnotToken) - . insertAnnotAnchors - else concatMap renderAnnotToken) - . annotTokenise baseLoc tx - --- | annotTokenise is absurdly slow: O(#tokens x #errors) - -annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)] -annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots - where - toks = tokeniseWithCommentTransform tx src - spans = tokenSpans baseLoc $ map snd toks - annots = fmap (spanAnnot linWidth annm) spans - linWidth = length $ show $ length $ lines src - -spanAnnot w (Ann ts es _) span = A t e b - where - t = fmap snd (M.lookup span ts) - e = fmap (\_ -> "ERROR") $ find (span `inRange`) [(x,y) | (x,y,_) <- es] - b = spanLine w span - -spanLine w (L (l, c)) - | c == 1 = Just (l, w) - | otherwise = Nothing - -inRange (L (l0, c0)) (L (l, c), L (l', c')) - = l <= l0 && c <= c0 && l0 <= l' && c0 < c' - -tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)] -tokeniseWithCommentTransform Nothing = tokenise -tokeniseWithCommentTransform (Just f) = concatMap (expand f) . tokenise - where expand f (Comment, s) = f s - expand _ z = [z] - -tokenSpans :: Maybe Loc -> [String] -> [Loc] -tokenSpans = scanl plusLoc . fromMaybe (L (1, 1)) - -plusLoc :: Loc -> String -> Loc -plusLoc (L (l, c)) s - = case '\n' `elemIndices` s of - [] -> L (l, (c + n)) - is -> L ((l + length is), (n - maximum is)) - where n = length s - -renderAnnotToken :: (TokenType, String, Annotation) -> String -renderAnnotToken (x, y, a) = renderLinAnnot (lin a) - $ renderErrAnnot (err a) - $ renderTypAnnot (typ a) - $ CSS.renderToken (x, y) - - - -renderTypAnnot (Just ann) s = printf "%s%s" (escape ann) s -renderTypAnnot Nothing s = s - -renderErrAnnot (Just _) s = printf "%s" s -renderErrAnnot Nothing s = s - -renderLinAnnot (Just d) s = printf "%s: %s" (lineString d) s -renderLinAnnot Nothing s = s - -lineString (i, w) = (replicate (w - (length is)) ' ') ++ is - where is = show i - -{- Example Annotation: -x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)} -NOWTRYTHIS --} - - -insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)] -insertAnnotAnchors toks - = stitch (zip toks' toks) $ insertAnchors toks' - where toks' = [(x,y) | (x,y,_) <- toks] - -stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c] -stitch xys ((Left a) : rest) - = (Left a) : stitch xys rest -stitch ((x,y):xys) ((Right x'):rest) - | x == x' - = (Right y) : stitch xys rest - | otherwise - = error "stitch" -stitch _ [] - = [] - - -splitSrcAndAnns :: String -> (String, AnnMap) -splitSrcAndAnns s = - let ls = lines s in - case findIndex (breakS ==) ls of - Nothing -> (s, Ann M.empty [] Safe) - Just i -> (src, ann) - where (codes, _:mname:annots) = splitAt i ls - ann = annotParse mname $ dropWhile isSpace $ unlines annots - src = unlines codes - -srcModuleName :: String -> String -srcModuleName = fromMaybe "Main" . tokenModule . tokenise - -tokenModule toks - = do i <- findIndex ((Keyword, "module") ==) toks - let (_, toks') = splitAt (i+2) toks - j <- findIndex ((Space ==) . fst) toks' - let (toks'', _) = splitAt j toks' - return $ concatMap snd toks'' - -breakS = "MOUSEOVER ANNOTATIONS" - --- annotParse :: String -> String -> AnnMap --- annotParse mname = Ann . M.map reduce . group . parseLines mname 0 . lines --- where --- group = foldl' (\m (k, v) -> inserts k v m) M.empty --- reduce anns@((x,_):_) = (x, mconcat $ map snd anns) --- inserts k v m = M.insert k (v : M.lookupDefault [] k m) m - -annotParse :: String -> String -> AnnMap -annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe - where - (ts, es) = partitionEithers $ parseLines mname 0 $ lines s - - -parseLines _ _ [] - = [] - -parseLines mname i ("":ls) - = parseLines mname (i+1) ls - -parseLines mname i (_:_:l:c:"0":l':c':rest') - = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest' - where line = (read l) :: Int - col = (read c) :: Int - line' = (read l') :: Int - col' = (read c') :: Int - -parseLines mname i (x:f:l:c:n:rest) - | f /= mname - = parseLines mname (i + 5 + num) rest' - | otherwise - = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest' - where line = (read l) :: Int - col = (read c) :: Int - num = (read n) :: Int - anns = intercalate "\n" $ take num rest - rest' = drop num rest - -parseLines _ i _ - = error $ "Error Parsing Annot Input on Line: " ++ show i - --- stringAnnotation s --- | "ERROR" `isPrefixOf` s = A Nothing (Just s) --- | otherwise = A (Just s) Nothing - --- takeFileName s = map slashWhite s --- where slashWhite '/' = ' ' - -instance Show AnnMap where - show (Ann ts es _ ) = "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts) - ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es]) - -ppAnnotTyp (L (l, c), (x, s)) = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s -ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c' - --- where ppAnnot (L (l, c), (x,s)) = x ++ "\n" --- ++ show l ++ "\n" --- ++ show c ++ "\n" --- ++ show (length $ lines s) ++ "\n" --- ++ s ++ "\n\n\n" - - ---------------------------------------------------------------------------------- ----- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour -- ---------------------------------------------------------------------------------- - --- | Separating literate files into code\/comment chunks. -data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show) - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. --- And retains the trailing '\n' character in each resultant string. -inlines :: String -> [String] -inlines s = lines' s id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id -- DOS ---lines' ('\^M':s) acc = acc ['\n'] : lines' s id -- MacOS - lines' ('\n':s) acc = acc ['\n'] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - - --- | The code for classify is largely stolen from Language.Preprocessor.Unlit. -classify :: [String] -> [Lit] -classify [] = [] -classify (x:xs) | "\\begin{code}"`isPrefixOf`x - = Lit x: allProg xs - where allProg [] = [] -- Should give an error message, - -- but I have no good position information. - allProg (x:xs) | "\\end{code}"`isPrefixOf`x - = Lit x: classify xs - allProg (x:xs) = Code x: allProg xs -classify (('>':x):xs) = Code ('>':x) : classify xs -classify (x:xs) = Lit x: classify xs - --- | Join up chunks of code\/comment that are next to each other. -joinL :: [Lit] -> [Lit] -joinL [] = [] -joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs) -joinL (Lit c :Lit c2 :xs) = joinL (Lit (c++c2):xs) -joinL (any:xs) = any: joinL xs - diff --git a/Language/Haskell/Liquid/ANFTransform.hs b/Language/Haskell/Liquid/ANFTransform.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/ANFTransform.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} - -------------------------------------------------------------------------------------- ------------- Code to convert Core to Administrative Normal Form --------------------- -------------------------------------------------------------------------------------- - -module Language.Haskell.Liquid.ANFTransform (anormalize) where -import Coercion (isCoVar, isCoVarType) -import CoreSyn -import CoreUtils (exprType) -import DsMonad (DsM, initDs) -import FastString (fsLit) -import GHC hiding (exprType) -import HscTypes -import Id (mkSysLocalM) -import Literal -import MkCore (mkCoreLets) -import Outputable (trace) -import Var (varType, setVarType) -import TypeRep -import Type (mkForAllTys, substTy, mkForAllTys, mkTopTvSubst) -import TyCon (tyConDataCons_maybe) -import DataCon (dataConInstArgTys) -import VarEnv (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv) -import Control.Monad -import Control.Applicative ((<$>)) -import Language.Fixpoint.Types (anfPrefix) -import Language.Haskell.Liquid.GhcMisc (MGIModGuts(..), showPpr) -import Language.Fixpoint.Misc (fst3, errorstar) -import Data.Maybe (fromMaybe) -import Data.List (sortBy, (\\)) - -anormalize :: HscEnv -> MGIModGuts -> IO [CoreBind] -anormalize hscEnv modGuts - = do -- putStrLn "***************************** GHC CoreBinds ***************************" - -- putStrLn $ showPpr orig_cbs - liftM (fromMaybe err . snd) $ initDs hscEnv m grEnv tEnv act - where m = mgi_module modGuts - grEnv = mgi_rdr_env modGuts - tEnv = modGutsTypeEnv modGuts - act = liftM concat $ mapM (normalizeTopBind emptyVarEnv) orig_cbs - orig_cbs = mgi_binds modGuts - err = errorstar "anormalize fails!" - -modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis - where ids = bindersOfBinds (mgi_binds mg) - tcs = mgi_tcs mg - fis = mgi_fam_insts mg - ------------------------------------------------------------------- ------------------ Actual Normalizing Functions ------------------- ------------------------------------------------------------------- - --- Can't make the below default for normalizeBind as it --- fails tests/pos/lets.hs due to GHCs odd let-bindings - -normalizeTopBind γ (NonRec x e) - = do e' <- stitch `fmap` normalize γ e - return [normalizeTyVars $ NonRec x e'] - -normalizeTopBind γ (Rec xes) - = liftM (map normalizeTyVars)(normalizeBind γ (Rec xes)) - -normalizeTyVars (NonRec x e) = NonRec (setVarType x t') e - where t' = subst msg as as' bt - msg = "WARNING unable to renameVars on " ++ showPpr x - as' = fst $ collectTyBinders e - (as, bt) = splitForAllTys (varType x) -normalizeTyVars (Rec xes) = Rec xes' - where nrec = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes) - xes' = (\(NonRec x e) -> (x, e)) <$> nrec - -subst msg as as' bt - | length as == length as' - = mkForAllTys as' $ substTy su bt - | otherwise - = trace msg $ mkForAllTys as bt - where su = mkTopTvSubst $ zip as (mkTyVarTys as') - ------------------------------------------------------------------- -normalizeBind :: VarEnv Id -> CoreBind -> DsM [CoreBind] ------------------------------------------------------------------- - -normalizeBind γ (NonRec x e) - = do (bs, e') <- normalize γ e - return (bs ++ [NonRec x e']) - -normalizeBind γ (Rec xes) - = do es' <- mapM (normalize γ >=> (return . stitch)) es - return [Rec (zip xs es')] - where (xs, es) = unzip xes - --------------------------------------------------------------------- -normalizeName :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr) --------------------------------------------------------------------- - --- normalizeNameDebug γ e --- = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e - -normalizeName _ e@(Lit (LitInteger _ _)) - = normalizeLiteral e - -normalizeName _ e@(Tick _ (Lit (LitInteger _ _))) - = normalizeLiteral e - -normalizeName γ (Var x) - = return ([], Var (lookupWithDefaultVarEnv γ x x)) - -normalizeName _ e@(Type _) - = return ([], e) - -normalizeName _ e@(Lit _) - = return ([], e) - -normalizeName γ e@(Coercion _) - = do x <- freshNormalVar $ exprType e - return ([NonRec x e], Var x) - -normalizeName γ (Tick n e) - = do (bs, e') <- normalizeName γ e - return (bs, Tick n e') - -normalizeName γ e - = do (bs, e') <- normalize γ e - x <- freshNormalVar $ exprType e - return (bs ++ [NonRec x e'], Var x) - ---------------------------------------------------------------------- -normalizeLiteral :: CoreExpr -> DsM ([CoreBind], CoreExpr) ---------------------------------------------------------------------- - -normalizeLiteral e = - do x <- freshNormalVar (exprType e) - return ([NonRec x e], Var x) - -freshNormalVar = mkSysLocalM (fsLit anfPrefix) - ---------------------------------------------------------------------- -normalize :: VarEnv Id -> CoreExpr -> DsM ([CoreBind], CoreExpr) ---------------------------------------------------------------------- - -normalize γ (Lam x e) - = do e' <- stitch `fmap` normalize γ e - return ([], Lam x e') - -normalize γ (Let b e) - = do bs' <- normalizeBind γ b - (bs'', e') <- normalize γ e - return (bs' ++ bs'', e') - -- Need to float bindings all the way up to the top - -- Due to GHCs odd let-bindings (see tests/pos/lets.hs) - -normalize γ (Case e x t as) - = do (bs, n) <- normalizeName γ e - x' <- freshNormalVar τx -- rename "wild" to avoid shadowing - let γ' = extendVarEnv γ x x' - as' <- forM as $ \(c, xs, e') -> liftM ((c, xs,) . stitch) (normalize γ' e') - as'' <- expandDefaultCase τx as' - return (bs, Case n x' t as'') - where τx = varType x - -normalize γ (Var x) - = return ([], Var (lookupWithDefaultVarEnv γ x x)) - -normalize _ e@(Lit _) - = return ([], e) - -normalize _ e@(Type _) - = return ([], e) - -normalize γ (Cast e τ) - = do (bs, e') <- normalize γ e - return (bs, Cast e' τ) - -normalize γ (App e1 e2) - = do (bs1, e1') <- normalize γ e1 - (bs2, n2 ) <- normalizeName γ e2 - return (bs1 ++ bs2, App e1' n2) - -normalize γ (Tick n e) - = do (bs, e') <- normalize γ e - return (bs, Tick n e') - -normalize _ (Coercion c) - = return ([], Coercion c) - -normalize _ e - = errorstar $ "ANFTransform.normalize: TODO" ++ showPpr e - -stitch :: ([CoreBind], CoreExpr) -> CoreExpr -stitch (bs, e) = mkCoreLets bs e - - ----------------------------------------------------------------------------------- -expandDefaultCase :: Type -> [(AltCon, [Id], CoreExpr)] -> DsM [(AltCon, [Id], CoreExpr)] ----------------------------------------------------------------------------------- - -expandDefaultCase (TyConApp tc argτs) z@((DEFAULT, _ ,e) : dcs) - = case tyConDataCons_maybe tc of - Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs] - dcs' <- forM ds' $ cloneCase argτs e - return $ sortCases $ dcs' ++ dcs - Nothing -> return z -- - -expandDefaultCase _ z - = return z - -cloneCase argτs e d - = do xs <- mapM freshNormalVar $ dataConInstArgTys d argτs - return (DataAlt d, xs, e) - -sortCases = sortBy (\x y -> cmpAltCon (fst3 x) (fst3 y)) - diff --git a/Language/Haskell/Liquid/Annotate.hs b/Language/Haskell/Liquid/Annotate.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Annotate.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- | This module contains the code that uses the inferred types to generate --- htmlized source with mouseover annotations. - -module Language.Haskell.Liquid.Annotate ( - - -- * Types representing annotations - AnnInfo (..) - , Annot (..) - - -- * Top-level annotation renderer function - , annotate - ) where - -import GHC ( SrcSpan (..) - , srcSpanStartCol - , srcSpanEndCol - , srcSpanStartLine - , srcSpanEndLine) - -import Var (Var (..)) -import Text.PrettyPrint.HughesPJ -import GHC.Exts (groupWith, sortWith) - -import Data.Char (isSpace) -import Data.Function (on) -import Data.List (sortBy) -import Data.Maybe (mapMaybe) - -import Data.Aeson -import Control.Arrow hiding ((<+>)) -import Control.Applicative ((<$>)) -import Control.DeepSeq -import Control.Monad (when) -import Data.Monoid - -import System.FilePath (takeFileName, dropFileName, ()) -import System.Directory (findExecutable) -import System.Directory (copyFile) -import Text.Printf (printf) - -import qualified Data.ByteString.Lazy as B -import qualified Data.Text as T -import qualified Data.HashMap.Strict as M - -import qualified Language.Haskell.Liquid.ACSS as ACSS - -import Language.Haskell.HsColour.Classify -import Language.Fixpoint.Files -import Language.Fixpoint.Names -import Language.Fixpoint.Misc -import Language.Haskell.Liquid.GhcMisc -- (Loc (..), pprDoc, showPpr) -import Language.Fixpoint.Types -import Language.Haskell.Liquid.Misc -import Language.Haskell.Liquid.RefType -import Language.Haskell.Liquid.Tidy -import Language.Haskell.Liquid.Types hiding (Located(..)) --- import Language.Haskell.Liquid.Result - -import qualified Data.List as L -import qualified Data.Vector as V - --- import Language.Fixpoint.Misc (inserts) --- import Language.Haskell.Liquid.ACSS - - -------------------------------------------------------------------- ------- Rendering HTMLized source with Inferred Types -------------- -------------------------------------------------------------------- - -annotate :: FilePath -> FixResult Error -> FixSolution -> AnnInfo Annot -> IO () -annotate fname result sol anna - = do annotDump fname (extFileName Html $ extFileName Cst fname) result annm - annotDump fname (extFileName Html fname) result annm' - showBots annm' - where - annm = closeAnnots anna - annm' = tidySpecType <$> applySolution sol annm - -showBots (AI m) = mapM_ showBot $ sortBy (compare `on` fst) $ M.toList m - where - showBot (src, (Just v, spec):_) = - when (isFalse (rTypeReft spec)) $ - printf "WARNING: Found false in %s\n" (showPpr src) - showBot _ = return () - -annotDump :: FilePath -> FilePath -> FixResult Error -> AnnInfo SpecType -> IO () -annotDump srcFile htmlFile result ann - = do let annm = mkAnnMap result ann - let annFile = extFileName Annot srcFile - let jsonFile = extFileName Json srcFile - B.writeFile jsonFile (encode annm) - writeFilesOrStrings annFile [Left srcFile, Right (show annm)] - annotHtmlDump htmlFile srcFile annm - return () - -writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO () -writeFilesOrStrings tgtFile = mapM_ $ either (`copyFile` tgtFile) (tgtFile `appendFile`) - -annotHtmlDump htmlFile srcFile annm - = do src <- readFile srcFile - let lhs = isExtFile LHs srcFile - let body = {-# SCC "hsannot" #-} ACSS.hsannot False (Just tokAnnot) lhs (src, annm) - cssFile <- getCssPath - copyFile cssFile (dropFileName htmlFile takeFileName cssFile) - renderHtml lhs htmlFile srcFile (takeFileName cssFile) body - -renderHtml True = renderPandoc -renderHtml False = renderDirect - -------------------------------------------------------------------------- --- | Pandoc HTML Rendering (for lhs + markdown source) ------------------ -------------------------------------------------------------------------- - -renderPandoc htmlFile srcFile css body - = 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 - writeFilesOrStrings htmlFile [Right (cssHTML css)] - checkExitCode cmd ec - 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 - -pandocPreProc = T.unpack . stripBegin . stripEnd . T.pack - where - stripBegin = T.replace (T.pack "\\begin{code}") T.empty - stripEnd = T.replace (T.pack "\\end{code}") T.empty - -------------------------------------------------------------------------- --- | Direct HTML Rendering (for non-lhs/markdown source) ---------------- -------------------------------------------------------------------------- - --- More or less taken from hscolour - -renderDirect htmlFile srcFile css body - = writeFile htmlFile $! (top'n'tail full srcFile css $! body) - where full = True -- False -- TODO: command-line-option - --- | @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) -top'n'tail False _ _ = id - --- Use this for standalone HTML - -htmlHeader title css = unlines - [ "" - , "" - , "" - , "" ++ title ++ "" - , "" - , cssHTML css - , "" - , "
" - , "Put mouse over identifiers to see inferred types" - ] - -htmlClose = "\n\n" - -cssHTML css = unlines - [ "" - , "" - , "" - ] - ------------------------------------------------------------------------------- --- | Building Annotation Maps ------------------------------------------------ ------------------------------------------------------------------------------- - --- | This function converts our annotation information into that which --- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover --- annotations. - -mkAnnMap :: FixResult Error -> AnnInfo SpecType -> ACSS.AnnMap -mkAnnMap res ann = ACSS.Ann (mkAnnMapTyp ann) (mkAnnMapErr res) (mkStatus res) - -mkStatus (Safe) = ACSS.Safe -mkStatus (Unsafe _) = ACSS.Unsafe -mkStatus (Crash _ _) = ACSS.Error -mkStatus _ = ACSS.Crash - -mkAnnMapErr (Unsafe 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 _ = Nothing - - -mkAnnMapTyp (AI m) = M.fromList - $ map (srcSpanStartLoc *** bindString) - $ map (head . sortWith (srcSpanEndCol . fst)) - $ groupWith (lineCol . fst) - $ [ (l, x) | (RealSrcSpan l, (x:_)) <- M.toList m, oneLine l] - where - bindString = mapPair render . pprXOT - -closeAnnots :: AnnInfo Annot -> AnnInfo SpecType -closeAnnots = closeA . filterA . collapseA - -closeA a@(AI m) = cf <$> a - where - cf (Loc loc) = case m `mlookup` loc of - [(_, Use t)] -> t - [(_, Def t)] -> t - [(_, RDf t)] -> t - _ -> errorstar $ "malformed AnnInfo: " ++ showPpr loc - cf (Use t) = t - cf (Def t) = t - cf (RDf t) = t - -filterA (AI m) = AI (M.filter ff m) - where ff [(_, Loc loc)] = loc `M.member` m - ff _ = True - -collapseA (AI m) = AI (fmap pickOneA m) - -pickOneA xas = case (rs, ds, ls, us) of - ((x:_), _, _, _) -> [x] - (_, (x:_), _, _) -> [x] - (_, _, (x:_), _) -> [x] - (_, _, _, (x:_)) -> [x] - where - rs = [x | x@(_, RDf _) <- xas] - ds = [x | x@(_, Def _) <- xas] - ls = [x | x@(_, Loc _) <- xas] - us = [x | x@(_, Use _) <- xas] - ------------------------------------------------------------------------------- --- | Tokenizing Refinement Type Annotations in @-blocks ---------------------- ------------------------------------------------------------------------------- - --- | The token used for refinement symbols inside the highlighted types in @-blocks. -refToken = Keyword - --- | The top-level function for tokenizing @-block annotations. Used to --- tokenize comments by ACSS. -tokAnnot s - = case trimLiquidAnnot s of - Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)] - Nothing -> [(Comment, s)] - -trimLiquidAnnot ('{':'-':'@':ss) - | drop (length ss - 3) ss == "@-}" - = Just ("{-@", take (length ss - 3) ss, "@-}") -trimLiquidAnnot _ - = Nothing - -tokBody s - | isData s = tokenise s - | isType s = tokenise s - | isIncl s = tokenise s - | isMeas s = tokenise s - | otherwise = tokeniseSpec s - -isMeas = spacePrefix "measure" -isData = spacePrefix "data" -isType = spacePrefix "type" -isIncl = spacePrefix "include" - -spacePrefix str s@(c:cs) - | isSpace c = spacePrefix str cs - | otherwise = (take (length str) s) == str -spacePrefix _ _ = False - - -tokeniseSpec :: String -> [(TokenType, String)] -tokeniseSpec str = {- traceShow ("tokeniseSpec: " ++ str) $ -} tokeniseSpec' str - -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) $ -} - filter (/= "") $ concatMap (chopAlts [("{", ":"), ("|", "}")]) - $ chopAlts [("<{", "}>"), ("{", "}")] y - ---------------------------------------------------------------- ----------------- Annotations and Solutions -------------------- ---------------------------------------------------------------- - -newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Var, a)]) - -data Annot = Use SpecType - | Def SpecType - | RDf SpecType - | Loc SrcSpan - -instance Monoid (AnnInfo a) where - mempty = AI M.empty - mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2 - -instance Functor AnnInfo where - fmap f (AI m) = AI (fmap (fmap (\(x, y) -> (x, f y))) m) - -instance PPrint a => PPrint (AnnInfo a) where - pprint (AI m) = vcat $ map pprAnnInfoBinds $ M.toList m - - -instance NFData a => NFData (AnnInfo a) where - rnf (AI x) = () -- rnf x - -instance NFData Annot where - rnf (Def x) = () -- rnf x - rnf (RDf x) = () -- rnf x - rnf (Use x) = () -- rnf x - rnf (Loc x) = () -- rnf x - -instance PPrint Annot where - pprint (Use t) = text "Use" <+> pprint t - pprint (Def t) = text "Def" <+> pprint t - pprint (RDf t) = text "RDf" <+> pprint t - pprint (Loc l) = text "Loc" <+> pprDoc l - -pprAnnInfoBinds (l, xvs) - = vcat $ map (pprAnnInfoBind . (l,)) xvs - -pprAnnInfoBind (RealSrcSpan k, xv) - = xd $$ pprDoc l $$ pprDoc c $$ pprint n $$ vd $$ text "\n\n\n" - where l = srcSpanStartLine k - c = srcSpanStartCol k - (xd, vd) = pprXOT xv - n = length $ lines $ render vd - -pprAnnInfoBind (_, _) - = empty - -pprXOT (x, v) = (xd, pprint v) - where xd = maybe (text "unknown") pprint x - -applySolution :: FixSolution -> AnnInfo SpecType -> AnnInfo SpecType -applySolution = fmap . fmap . mapReft . map . appSolRefa - where appSolRefa _ ra@(RConc _) = ra - -- appSolRefa _ p@(RPvar _) = p - appSolRefa s (RKvar k su) = RConc $ subst su $ M.lookupDefault PTop k s - mapReft f (U (Reft (x, zs)) p) = U (Reft (x, squishRefas $ f zs)) p - - - ------------------------------------------------------------------------- --- | JSON: Annotation Data Types --------------------------------------- ------------------------------------------------------------------------- - -data Assoc k a = Asc (M.HashMap k a) -type AnnTypes = Assoc Int (Assoc Int Annot1) -type AnnErrors = [(Loc, Loc, String)] -data Annot1 = A1 { ident :: String - , ann :: String - , row :: Int - , col :: Int - } - ------------------------------------------------------------------------- --- | JSON Instances ---------------------------------------------------- ------------------------------------------------------------------------- - -instance ToJSON ACSS.Status where - toJSON ACSS.Safe = "safe" - toJSON ACSS.Unsafe = "unsafe" - toJSON ACSS.Error = "error" - toJSON ACSS.Crash = "crash" - -instance ToJSON Annot1 where - toJSON (A1 i a r c) = object [ "ident" .= i - , "ann" .= a - , "row" .= r - , "col" .= c - ] - -instance ToJSON Loc where - toJSON (L (l, c)) = object [ ("line" .= toJSON l) - , ("column" .= toJSON c) ] - -instance ToJSON AnnErrors where - toJSON errs = Array $ V.fromList $ fmap toJ errs - 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 - -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 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 - 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 - Asc rm = M.lookupDefault (Asc M.empty) r m - --------------------------------------------------------------------------------- --- | A Little Unit Test -------------------------------------------------------- --------------------------------------------------------------------------------- - -anns :: AnnTypes -anns = i [(5, i [( 14, A1 { ident = "foo" - , ann = "int -> int" - , row = 5 - , col = 14 - }) - ] - ) - ,(9, i [( 22, A1 { ident = "map" - , ann = "(a -> b) -> [a] -> [b]" - , row = 9 - , col = 22 - }) - ,( 28, A1 { ident = "xs" - , ann = "[b]" - , row = 9 - , col = 28 - }) - ]) - ] - -i = Asc . M.fromList - - - diff --git a/Language/Haskell/Liquid/Bare.hs b/Language/Haskell/Liquid/Bare.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Bare.hs +++ /dev/null @@ -1,1338 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances, TupleSections, ScopedTypeVariables #-} - --- | This module contains the functions that convert /from/ descriptions of --- symbols, names and types (over freshly parsed /bare/ Strings), --- /to/ representations connected to GHC vars, names, and types. --- The actual /representations/ of bare and real (refinement) types are all --- in `RefType` -- they are different instances of `RType` - -module Language.Haskell.Liquid.Bare ( - GhcSpec (..) - , makeGhcSpec - -- , varSpecType - ) where - -import GHC hiding (lookupName, Located) -import Text.PrettyPrint.HughesPJ hiding (first) -import Var -import Name (getSrcSpan) -import Id (isConLikeId) -import PrelNames -import PrelInfo (wiredInThings) -import Type (expandTypeSynonyms, splitFunTy_maybe) -import DataCon (dataConImplicitIds, dataConWorkId) -import TyCon (tyConArity) -import HscMain -import TysWiredIn -import BasicTypes (TupleSort (..), Arity) -import TcRnDriver (tcRnLookupRdrName, tcRnLookupName) -import RdrName (setRdrNameSpace) -import OccName (tcName) -import Data.Char (isLower, isUpper) -import Text.Printf -import Data.Maybe (listToMaybe, fromMaybe, mapMaybe, catMaybes, isNothing) -import Control.Monad.State (put, get, gets, modify, State, evalState, evalStateT, execState, StateT) -import Data.Traversable (forM) -import Control.Applicative ((<$>), (<*>), (<|>)) -import Control.Monad.Reader hiding (forM) -import Control.Monad.Error hiding (Error, forM) -import Control.Monad.Writer hiding (forM) -import qualified Control.Exception as Ex --- import Data.Data hiding (TyCon, tyConName) -import Data.Bifunctor -import Data.Function (on) - -import Language.Fixpoint.Misc -import Language.Fixpoint.Names (propConName, takeModuleNames, dropModuleNames) -import Language.Fixpoint.Types hiding (Predicate) -import Language.Fixpoint.Sort (checkSortedReftFull) -import Language.Haskell.Liquid.GhcMisc hiding (L) -import Language.Haskell.Liquid.Misc -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType -import Language.Haskell.Liquid.PredType hiding (unify) -import qualified Language.Haskell.Liquid.Measure as Ms - -import qualified Data.List as L -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as M -import TypeRep ------------------------------------------------------------------- ----------- Top Level Output -------------------------------------- ------------------------------------------------------------------- - -makeGhcSpec :: Config -> ModName -> [Var] -> [Var] -> HscEnv - -> [(ModName,Ms.Spec BareType Symbol)] - -> IO GhcSpec -makeGhcSpec cfg name vars defVars env specs - = either Ex.throw return . checkGhcSpec =<< execBare (makeGhcSpec' cfg vars defVars specs) initEnv - where initEnv = BE name mempty mempty mempty env - -checkMeasures emb env ms = concatMap (checkMeasure emb env) ms - -checkMeasure :: M.HashMap TyCon FTycon-> SEnv SortedReft -> Ms.Measure SpecType DataCon -> [Error] -checkMeasure emb γ (Ms.M name@(Loc src n) sort body) - = [txerror e | Just e <- checkMBody γ emb name sort <$> body] - where - txerror = ErrMeas (sourcePosSrcSpan src) n - -checkMBody γ emb name sort (Ms.Def s c bs body) = go γ' body - where - γ' = foldl (\γ (x, t) -> insertSEnv x t γ) γ xts - xts = zip bs $ rTypeSortedReft emb . subsTyVars_meet su <$> ts - ct = ofType $ dataConUserType c :: SpecType - su = unify tr (head $ snd3 $ bkArrowDeep sort) - - (_, ts, tr) = bkArrow $ thd3 $ bkUniv ct - - unify (RVar tv _) t = [(tv, toRSort t, t)] - unify (RApp _ ts _ _) (RApp _ ts' _ _) = concat $ zipWith unify ts ts' - unify _ _ = [] - - go γ (Ms.E e) = checkSortedReftFull γ e - go γ (Ms.P p) = checkSortedReftFull γ p - go γ (Ms.R s p) = checkSortedReftFull (insertSEnv s sty γ) p - - sty = rTypeSortedReft emb (thd3 $ bkArrowDeep sort) - -makeGhcSpec' :: Config -> [Var] -> [Var] - -> [(ModName,Ms.Spec BareType Symbol)] - -> BareM (GhcSpec, [Ms.Measure SpecType DataCon]) -makeGhcSpec' cfg vars defVars specs - = do name <- gets modName - makeRTEnv (concat [map (mod,) $ Ms.aliases sp | (mod,sp) <- specs]) - (concat [map (mod,) $ Ms.paliases sp | (mod,sp) <- specs]) - (tcs, dcs) <- mconcat <$> mapM makeConTypes specs - let (tcs', dcs') = wiredTyDataCons - let tycons = tcs ++ tcs' - let datacons = concat dcs ++ dcs' - modify $ \be -> be { tcEnv = makeTyConInfo tycons } - measures <- mconcat <$> mapM makeMeasureSpec specs - let (cs, ms) = makeMeasureSpec' measures - sigs' <- mconcat <$> mapM (makeAssumeSpec cfg vars) specs - invs <- mconcat <$> mapM makeInvariants specs - embs <- mconcat <$> mapM makeTyConEmbeds specs - targetVars <- makeTargetVars name defVars $ binders cfg - lazies <- mconcat <$> mapM makeLazies specs - tcEnv <- gets tcEnv - let sigs = [ (x, (txRefSort tcEnv embs . txExpToBind) <$> t) - | (m, x, t) <- sigs' ] - let cs' = mapSnd (Loc dummyPos) <$> meetDataConSpec cs datacons - let ms' = [ (x, Loc l t) | (Loc l x, t) <- ms ] -- first val <$> ms - syms <- makeSymbols (vars ++ map fst cs') (map fst ms) (sigs ++ cs') ms' - let su = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms] - let tx = subsFreeSymbols su - let txq = subsFreeSymbolsQual su - let syms' = [(varSymbol v, v) | (_, v) <- syms] - let decr' = mconcat $ map (makeHints defVars) specs - let lvars' = S.fromList $ mconcat $ [ makeLVars defVars (mod,spec) - | (mod,spec) <- specs - , mod == name - ] - quals <- mconcat <$> mapM makeQualifiers specs - return $ (SP { tySigs = renameTyVars <$> tx sigs - , ctor = tx cs' - , meas = tx (ms' ++ varMeasures vars) - , invariants = invs - , dconsP = datacons - , tconsP = tycons - , freeSyms = syms' - , tcEmbeds = embs - , qualifiers = txq quals - , decr = decr' - , lvars = lvars' - , lazy = lazies - , tgtVars = targetVars - , config = cfg - } - , subst su <$> M.elems $ Ms.measMap measures) - ---- Refinement Type Aliases - -makeRTEnv rts pts = do initRTEnv - makeRPAliases pts - makeRTAliases rts - where initRTEnv = do forM_ rts $ \(mod,rta) -> setRTAlias (rtName rta) $ Left (mod,rta) - forM_ pts $ \(mod,pta) -> setRPAlias (rtName pta) $ Left (mod,pta) - - -makeRTAliases xts = mapM_ expBody xts - where expBody (mod,xt) = inModule mod $ do - body <- withVArgs (rtVArgs xt) $ expandRTAlias $ rtBody xt - setRTAlias (rtName xt) - $ Right $ mapRTAVars stringRTyVar $ xt { rtBody = body } - -makeRPAliases xts = mapM_ expBody xts - where expBody (mod,xt) = inModule mod $ do - env <- gets $ predAliases . rtEnv - body <- withVArgs (rtVArgs xt) $ expandRPAliasE $ rtBody xt - setRPAlias (rtName xt) $ Right $ xt { rtBody = body } - --- | Using the Alias Environment to Expand Definitions -expandRTAliasMeasure m - = do eqns <- sequence $ expandRTAliasDef <$> (Ms.eqns m) - return $ m { Ms.sort = generalize (Ms.sort m) - , Ms.eqns = eqns } - -expandRTAliasDef :: Ms.Def Symbol -> BareM (Ms.Def Symbol) -expandRTAliasDef d - = do env <- gets rtEnv - body <- expandRTAliasBody env $ Ms.body d - return $ d { Ms.body = body } - -expandRTAliasBody :: RTEnv -> Ms.Body -> BareM Ms.Body -expandRTAliasBody env (Ms.P p) = Ms.P <$> (expPAlias p) -expandRTAliasBody env (Ms.R x p) = Ms.R x <$> (expPAlias p) -expandRTAliasBody _ (Ms.E e) = Ms.E <$> resolve e - -expPAlias :: Pred -> BareM Pred -expPAlias = expandPAlias [] - - -expandRTAlias :: BareType -> BareM SpecType -expandRTAlias bt = expType =<< expReft bt - where - expReft = mapReftM (txPredReft expPred) - expType = expandAlias [] - expPred = expandPAlias [] - -txPredReft :: (Pred -> BareM Pred) -> RReft -> BareM RReft -txPredReft f (U r p) = (`U` p) <$> txPredReft' f r - where - txPredReft' f (Reft (v, ras)) = Reft . (v,) <$> mapM (txPredRefa f) ras - txPredRefa f (RConc p) = RConc <$> f p - txPredRefa _ z = return z - --- | Using the Alias Environment to Expand Definitions - -expandRPAliasE = expandPAlias [] - -expandRTAliasE = expandAlias [] - -expandAlias s = go s - where - go s (RApp c ts rs r) - | c `elem` s = errorstar $ "Cyclic Reftype Alias Definition: " ++ show (c:s) - | otherwise = do - env <- gets (typeAliases.rtEnv) - case M.lookup c env of - Just (Left (mod,rtb)) -> do - st <- inModule mod $ withVArgs (rtVArgs rtb) $ expandAlias (c:s) $ rtBody rtb - let rts = mapRTAVars stringRTyVar $ rtb { rtBody = st } - setRTAlias c $ Right rts - r' <- resolve r - expandRTApp s rts ts r' - Just (Right rts) -> do - r' <- resolve r - withVArgs (rtVArgs rts) $ expandRTApp s rts ts r' - Nothing | isList c && length ts == 1 -> do - tyi <- tcEnv <$> get - r' <- resolve r - liftM2 (bareTCApp tyi r' listTyCon) (mapM (go' s) rs) (mapM (go s) ts) - | isTuple c -> do - tyi <- tcEnv <$> get - r' <- resolve r - let tc = tupleTyCon BoxedTuple (length ts) - liftM2 (bareTCApp tyi r' tc) (mapM (go' s) rs) (mapM (go s) ts) - | otherwise -> do - tyi <- tcEnv <$> get - r' <- resolve r - liftM3 (bareTCApp tyi r') (lookupGhcTyCon c) (mapM (go' s) rs) (mapM (go s) ts) - go s (RVar a r) = RVar (stringRTyVar a) <$> resolve r - go s (RFun x t t' r) = rFun x <$> go s t <*> go s t' - go s (RAppTy t t' r) = rAppTy <$> go s t <*> go s t' - go s (RAllE x t1 t2) = liftM2 (RAllE x) (go s t1) (go s t2) - go s (REx x t1 t2) = liftM2 (REx x) (go s t1) (go s t2) - go s (RAllT a t) = RAllT (stringRTyVar a) <$> go s t - go s (RAllP a t) = RAllP <$> ofBPVar a <*> go s t - go s (RCls c ts) = RCls <$> lookupGhcClass c <*> (mapM (go s) ts) - go _ (ROth s) = return $ ROth s - go _ (RExprArg e) = return $ RExprArg e - - go' s (RMono ss r) = RMono <$> mapM ofSyms ss <*> resolve r - go' s (RPoly ss t) = RPoly <$> mapM ofSyms ss <*> go s t - -expandRTApp s rta args r - | length args == (length αs) + (length εs) - = do args' <- mapM (expandAlias s) args - let ts = take (length αs) args' - αts = zipWith (\α t -> (α, toRSort t, t)) αs ts - return $ subst su . (`strengthen` r) . subsTyVars_meet αts $ rtBody rta - | otherwise - = errortext $ (text "Malformed Type-Alias Application" $+$ text msg) - where - su = mkSubst $ zip (stringSymbol . showpp <$> εs) es - αs = rtTArgs rta - εs = rtVArgs rta - msg = rtName rta ++ " " ++ join (map showpp args) - es_ = drop (length αs) args - es = map (exprArg msg) es_ - --- | exprArg converts a tyVar to an exprVar because parser cannot tell --- HORRIBLE HACK To allow treating upperCase X as value variables X --- e.g. type Matrix a Row Col = List (List a Row) Col - -exprArg _ (RExprArg e) - = e -exprArg _ (RVar x _) - = EVar (stringSymbol $ showpp x) -exprArg _ (RApp x [] [] _) - = EVar (stringSymbol $ showpp x) -exprArg msg (RApp f ts [] _) - = EApp (stringSymbol $ showpp f) (exprArg msg <$> ts) -exprArg msg (RAppTy (RVar f _) t _) - = EApp (stringSymbol $ showpp f) [exprArg msg t] -exprArg msg z - = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg - -expandPAlias :: [Symbol] -> Pred -> BareM Pred -expandPAlias s = go s - where - go s p@(PBexp (EApp f es)) - | f `elem` s = errorstar $ "Cyclic Predicate Alias Definition: " ++ show (f:s) - | otherwise = do - env <- gets (predAliases.rtEnv) - case M.lookup (symbolString f) env of - Just (Left (mod,rp)) -> do - body <- inModule mod $ withVArgs (rtVArgs rp) $ expandPAlias (f:s) $ rtBody rp - let rp' = rp { rtBody = body } - setRPAlias (show f) $ Right $ rp' - expandRPApp (f:s) rp' <$> mapM resolve es - Just (Right rp) -> - withVArgs (rtVArgs rp) (expandRPApp (f:s) rp <$> mapM resolve es) - Nothing -> fmap PBexp (EApp <$> resolve f <*> mapM resolve es) - go s (PAnd ps) = PAnd <$> (mapM (go s) ps) - go s (POr ps) = POr <$> (mapM (go s) ps) - go s (PNot p) = PNot <$> (go s p) - go s (PImp p q) = PImp <$> (go s p) <*> (go s q) - go s (PIff p q) = PIff <$> (go s p) <*> (go s q) - go s (PAll xts p) = PAll xts <$> (go s p) - go _ p = resolve p - -expandRPApp s rp es - = let su = mkSubst $ safeZip msg (rtVArgs rp) es - msg = "expandRPApp: " ++ show (EApp (symbol $ rtName rp) es) - in subst su $ rtBody rp - - -makeQualifiers (mod,spec) = inModule mod mkQuals - where - mkQuals = mapM resolve $ Ms.qualifiers spec - -makeHints vs (_,spec) = makeHints' vs $ Ms.decr spec -makeLVars vs (_,spec) = fst <$> (makeHints' vs $ [(v, ()) | v <- Ms.lvars spec]) - -makeHints' :: [Var] -> [(LocSymbol, a)] -> [(Var, a)] -makeHints' vs = concatMap go - where lvs = M.map L.sort $ group [(varSymbol v, locVar v) | v <- vs] - varSymbol = stringSymbol . dropModuleNames . showPpr - locVar v = (getSourcePos v, v) - go (s, ns) = case M.lookup (val s) lvs of - Just lvs -> (, ns) <$> varsAfter s lvs - Nothing -> errorstar $ msg s - msg s = printf "%s: Hint for Undefined Var %s" - (show (loc s)) (show (val s)) - -varsAfter s lvs - | eqList (fst <$> lvs) - = snd <$> lvs - | otherwise - = map snd $ takeEqLoc $ dropLeLoc lvs - where takeEqLoc xs@((l, _):_) = L.takeWhile ((l==) . fst) xs - takeEqLoc [] = [] - dropLeLoc = L.dropWhile ((loc s >) . fst) - eqList [] = True - eqList (x:xs) = all (==x) xs - -txRefSort env embs = mapBot (addSymSort embs env) - -addSymSort embs tcenv (RApp rc@(RTyCon c _ _) ts rs r) - = RApp rc ts (addSymSortRef <$> zip ps rs) r - where ps = rTyConPs $ appRTyCon embs tcenv rc ts -addSymSort _ _ t - = t - -addSymSortRef (p, RPoly s (RVar v r)) | isDummy v - = RPoly (safeZip "addRefSortPoly" (fst <$> s) (fst3 <$> pargs p)) t - where t = ofRSort (ptype p) `strengthen` r -addSymSortRef (p, RPoly s t) - = RPoly (safeZip "addRefSortPoly" (fst <$> s) (fst3 <$> pargs p)) t - -addSymSortRef (p, RMono s r@(U _ (Pr [up]))) - = RMono (safeZip "addRefSortMono" (snd3 <$> pargs up) (fst3 <$> pargs p)) r -addSymSortRef (p, RMono s t) - = RMono s t - -varMeasures vars = [ (varSymbol v, varSpecType v) - | v <- vars - , isDataConWorkId v - , isSimpleType $ varType v - ] - -varSpecType v = Loc (getSourcePos v) (ofType $ varType v) - - -isSimpleType t = null tvs && isNothing (splitFunTy_maybe tb) - where (tvs, tb) = splitForAllTys t -------------------------------------------------------------------------------- --- Renaming Type Variables in Haskell Signatures ------------------------------ -------------------------------------------------------------------------------- - --- This throws an exception if there is a mismatch --- renameTyVars :: (Var, SpecType) -> (Var, SpecType) -renameTyVars (x, lt@(Loc l t)) - | length as == length αs = (x, Loc l $ mkUnivs (rTyVar <$> αs) [] t') - | otherwise = Ex.throw $ err - where - t' = subts su (mkUnivs [] ps tbody) - su = [(y, rTyVar x) | (x, y) <- tyvsmap] - tyvsmap = vmap $ execState (mapTyVars τbody tbody) initvmap - initvmap = initMapSt αs as err - (αs, τbody) = splitForAllTys $ expandTypeSynonyms $ varType x - (as, ps, tbody) = bkUniv t - err = errTypeMismatch x lt - - -data MapTyVarST = MTVST { τvars :: S.HashSet Var - , tvars :: S.HashSet RTyVar - , vmap :: [(Var, RTyVar)] - , errmsg :: Error - } - -initMapSt α a = MTVST (S.fromList α) (S.fromList a) [] - -mapTyVars :: (PPrint r, Reftable r) => Type -> RRType r -> State MapTyVarST () -mapTyVars τ (RAllT a t) - = do modify $ \s -> s{ tvars = S.delete a (tvars s) } - mapTyVars τ t -mapTyVars (ForAllTy α τ) t - = do modify $ \s -> s{ τvars = S.delete α (τvars s) } - mapTyVars τ t -mapTyVars (FunTy τ τ') (RFun _ t t' _) - = mapTyVars τ t >> mapTyVars τ' t' -mapTyVars (TyConApp _ τs) (RApp _ ts _ _) - = zipWithM_ mapTyVars τs ts -mapTyVars (TyVarTy α) (RVar a _) - = modify $ \s -> mapTyRVar α a s -mapTyVars τ (RAllP _ t) - = mapTyVars τ t -mapTyVars τ (RCls _ ts) - = return () -mapTyVars τ (RAllE _ _ t) - = mapTyVars τ t -mapTyVars τ (REx _ _ t) - = mapTyVars τ t -mapTyVars τ (RExprArg _) - = return () -mapTyVars (AppTy τ τ') (RAppTy t t' _) - = do mapTyVars τ t - mapTyVars τ' t' -mapTyVars τ t - = Ex.throw =<< errmsg <$> get - -- errorstar $ "Bare.mapTyVars : " ++ err - -mapTyRVar α a s@(MTVST αs as αas err) - | (α `S.member` αs) && (a `S.member` as) - = MTVST (S.delete α αs) (S.delete a as) ((α, a):αas) err - | (not (α `S.member` αs)) && (not (a `S.member` as)) - = s - | otherwise - = Ex.throw err -- errorstar err - -mkVarExpr v - | isDataConWorkId v && not (null tvs) && isNothing tfun - = EApp (dataConSymbol (idDataCon v)) [] - | otherwise - = EVar $ varSymbol v - where t = varType v - (tvs, tbase) = splitForAllTys t - tfun = splitFunTy_maybe tbase - -subsFreeSymbols su = tx - where - tx = fmap $ mapSnd $ subst su - -subsFreeSymbolsQual su = tx - where - tx = fmap $ mapBody $ subst su - mapBody f (Q n p b) = Q n p (f b) - --- meetDataConSpec :: [(Var, SpecType)] -> [(DataCon, DataConP)] -> [(Var, SpecType)] -meetDataConSpec xts dcs = M.toList $ L.foldl' upd dcm xts - where - dcm = M.fromList $ dataConSpec dcs - upd dcm (x, t) = M.insert x (maybe t (meetPad t) (M.lookup x dcm)) dcm - strengthen (x,t) = (x, maybe t (meetPad t) (M.lookup x dcm)) - - --- dataConSpec :: [(DataCon, DataConP)] -> [(Var, SpecType)] -dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType Class RTyCon RTyVar RReft))] -dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs] - -meetPad t1 t2 = -- traceShow ("meetPad: " ++ msg) $ - case (bkUniv t1, bkUniv t2) of - ((_, π1s, _), (α2s, [], t2')) -> meet t1 (mkUnivs α2s π1s t2') - ((α1s, [], t1'), (_, π2s, _)) -> meet (mkUnivs α1s π2s t1') t2 - _ -> errorstar $ "meetPad: " ++ msg - where msg = "\nt1 = " ++ showpp t1 ++ "\nt2 = " ++ showpp t2 - ------------------------------------------------------------------- ----------- Error-Reader-IO For Bare Transformation --------------- ------------------------------------------------------------------- - -type BareM a = WriterT [Warn] (ErrorT String (StateT BareEnv IO)) a - -type Warn = String - -data BareEnv = BE { modName :: !ModName - , tcEnv :: !(M.HashMap TyCon RTyCon) - , rtEnv :: !RTEnv - , varEnv :: ![(Symbol,Var)] - , hscEnv :: HscEnv } - -setModule m b = b { modName = m } - -inModule m act = do - old <- gets modName - modify $ setModule m - res <- act - modify $ setModule old - return res - -withVArgs vs act = do - old <- gets rtEnv - mapM (mkExprAlias . showpp) vs - res <- act - modify $ \be -> be { rtEnv = old } - return res - -addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] } - -mkExprAlias v - = setRTAlias v (Right (RTA v [] [] (RExprArg (EVar $ symbol v)) dummyPos)) - -setRTAlias s a = - modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b } - -setRPAlias s a = - modify $ \b -> b { rtEnv = mapRP (M.insert s a) $ rtEnv b } - -execBare :: BareM a -> BareEnv -> IO a -execBare act benv = - do z <- evalStateT (runErrorT (runWriterT act)) benv - case z of - Left s -> errorstar $ "execBare:\n " ++ s - Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++) - return x - -wrapErr msg f x = yesStack - where - noStack = f x - yesStack = noStack `catchError` \e -> throwError $ str e - str e = printf "Bare Error %s: \nThrows Exception: %s\n" msg e - ------------------------------------------------------------------- -------------------- API: Bare Refinement Types ------------------- ------------------------------------------------------------------- - -makeMeasureSpec (mod,spec) = inModule mod mkSpec - where - mkSpec = mkMeasureDCon =<< wrapErr "mkMeasureSort" mkMeasureSort =<< m - m = Ms.mkMSpec <$> (mapM expandRTAliasMeasure $ Ms.measures spec) - -makeMeasureSpec' = mapFst (mapSnd uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft) - - -makeTargetVars :: ModName -> [Var] -> [String] -> BareM [Var] -makeTargetVars name vs ss = do - env <- gets hscEnv - ns <- liftIO $ catMaybes <$> mapM (lookupName env name) (map prefix ss) - return $ filter ((`elem` ns) . varName) vs - where - prefix s = getModString name ++ "." ++ s - - -makeAssumeSpec cfg vs (mod,spec) - = inModule mod $ makeAssumeSpec' cfg vs $ Ms.sigs spec - -makeAssumeSpec' :: Config -> [Var] -> [(LocSymbol, BareType)] - -> BareM [(ModName, Var, Located SpecType)] -makeAssumeSpec' cfg vs xbs - = do vbs <- map (joinVar vs) <$> lookupIds xbs - env@(BE { modName = mod}) <- get - when (not $ noCheckUnknown cfg) $ - checkDefAsserts env vbs xbs - map (addFst3 mod) <$> mapM mkVarSpec vbs - --- the Vars we lookup in GHC don't always have the same tyvars as the Vars --- we're given, so return the original var when possible. --- see tests/pos/ResolvePred.hs for an example -joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of - Just v' -> (v',s,t) - Nothing -> (v,s,t) - -lookupIds xs = mapM lookup xs - where - lookup (s, t) = (,s,t) <$> lookupGhcVar (ss s) - ss = symbolString . symbol - -checkDefAsserts :: BareEnv -> [(Var, LocSymbol, BareType)] -> [(LocSymbol, BareType)] -> BareM () -checkDefAsserts env vbs xbs = applyNonNull (return ()) grumble undefSigs - where - undefSigs = [x | (x, _) <- assertSigs, not (x `S.member` definedSigs)] - assertSigs = filter isTarget xbs - definedSigs = S.fromList $ snd3 <$> vbs - grumble xs = mapM_ (warn . berrUnknownVar) xs -- [berrUnknownVar (loc x) (val x) | x <- xs] - moduleName = getModString $ modName env - isTarget = L.isPrefixOf moduleName . symbolStringRaw . val . fst - symbolStringRaw = stripParens . symbolString - - -- grumble = {- throwError -} warn . render . vcat . fmap errorMsg - -- errorMsg = (text "Specification for unknown variable:" <+>) . locatedSymbolText - - -warn x = tell [x] - - - - - -mkVarSpec :: (Var, LocSymbol, BareType) -> BareM (Var, Located SpecType) -mkVarSpec (v, Loc l _, b) = ((v, ) . (Loc l) . generalize) <$> mkSpecType msg b - where - msg = berrVarSpec l v b - - - -showTopLevelVars vs = - forM vs $ \v -> - if isExportedId v - then donePhase Loud ("Exported: " ++ showPpr v) - else return () - ----------------------------------------------------------------------- - -makeTyConEmbeds (mod,spec) - = inModule mod $ makeTyConEmbeds' $ Ms.embeds spec - -makeTyConEmbeds' :: TCEmb (Located String) -> BareM (TCEmb TyCon) -makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z) - where - tx (c, y) = (, y) <$> lookupGhcTyCon' c -- wrapErr () (lookupGhcTyCon (val c)) - - -lookupGhcTyCon' c = wrapErr msg lookupGhcTyCon (val c) - where - msg :: String = berrUnknownTyCon c - - -makeLazies (mod,spec) - = inModule mod $ makeLazies' $ Ms.lazy spec - -makeLazies' :: S.HashSet Symbol -> BareM (S.HashSet Var) -makeLazies' s = S.fromList <$> (fmap fst3 <$> lookupIds xxs) - where xs = S.toList s - xxs = zip xs xs - - -makeInvariants (mod,spec) - = inModule mod $ makeInvariants' $ Ms.invariants spec - -makeInvariants' :: [Located BareType] -> BareM [Located SpecType] -makeInvariants' ts = mapM mkI ts - where - mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType (berrInvariant l t) t - -mkSpecType msg t = mkSpecType' msg (snd3 $ bkUniv t) t - -mkSpecType' :: String -> [PVar BSort] -> BareType -> BareM SpecType -mkSpecType' msg πs = expandRTAlias . txParams subvUReft (uPVar <$> πs) - -makeSymbols vs xs' xts yts = mkxvs - where - xs'' = val <$> xs' - zs = (concatMap freeSymbols ((snd <$> xts))) `sortDiff` xs'' - zs' = (concatMap freeSymbols ((snd <$> yts))) `sortDiff` xs'' - xs = sortNub $ zs ++ zs' - mkxvs = do - svs <- gets varEnv - return [(x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)] - -freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (\ _ -> ()) f emptySEnv [] (val ty) - where - f γ _ r xs = let Reft (v, _) = toReft r in - [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs - ------------------------------------------------------------------ ------- Querying GHC for Id, Type, Class, Con etc. --------------- ------------------------------------------------------------------ - -class GhcLookup a where - lookupName :: HscEnv -> ModName -> a -> IO (Maybe Name) - candidates :: a -> [a] - pp :: a -> String - -instance GhcLookup String where - lookupName = stringLookup - candidates x = [x] - pp x = x - -instance GhcLookup Name where - lookupName _ _ = return . Just - candidates x = [x] - pp = showPpr - -lookupGhcThing :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM b -lookupGhcThing name f x - = do zs <- catMaybes <$> mapM (lookupGhcThing' name f) (candidates x) - case zs of - x:_ -> return x - _ -> throwError $ "lookupGhcThing unknown " ++ name ++ " : " ++ (pp x) - -lookupGhcThing' :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM (Maybe b) -lookupGhcThing' _ f x - = do (BE mod _ _ _ env) <- get - z <- liftIO $ lookupName env mod x - case z of - Nothing -> return Nothing - Just n -> liftIO $ liftM (join . (f <$>) . snd) (tcRnLookupName env n) - -stringLookup :: HscEnv -> ModName -> String -> IO (Maybe Name) -stringLookup env mod k - | k `M.member` wiredIn - = return $ M.lookup k wiredIn - | otherwise - = stringLookupEnv env mod k - -stringLookupEnv env mod s - | isSrcImport mod - = do let modName = getModName mod - L _ rn <- hscParseIdentifier env s - res <- lookupRdrName env modName rn - case res of - Just _ -> return res - Nothing -> lookupRdrName env modName (setRdrNameSpace rn tcName) - | otherwise - = do L _ rn <- hscParseIdentifier env s - (_, lookupres) <- tcRnLookupRdrName env rn - case lookupres of - Just (n:_) -> return (Just n) - _ -> return Nothing - -lookupGhcVar :: GhcLookup a => a -> BareM Var -lookupGhcVar x - -- It's possible that we have already resolved the Name we are - -- looking for, but have had to turn it back into a String, e.g. to - -- be used in an Expr, as in {v:Ordering | v = EQ}. In this case, - -- the fully-qualified Name (GHC.Types.EQ) will likely not be in - -- scope, so we store our own mapping of fully-qualified Names to - -- Vars and prefer pulling Vars from it. - = do env <- gets varEnv - case L.lookup (symbol $ pp x) env of - Nothing -> lookupGhcThing "Var" fv x - Just v -> return v - where - fv (AnId x) = Just x - fv (ADataCon x) = Just $ dataConWorkId x - fv _ = Nothing - -lookupGhcTyCon :: GhcLookup a => a -> BareM TyCon -lookupGhcTyCon s = (lookupGhcThing "TyCon" ftc s) `catchError` (tryPropTyCon s) - where - ftc (ATyCon x) = Just x - ftc (ADataCon x) = Just $ dataConTyCon x - ftc _ = Nothing - -tryPropTyCon s e - | pp s == propConName = return propTyCon - | otherwise = throwError e - -lookupGhcClass = lookupGhcThing "Class" ftc - where - ftc (ATyCon x) = tyConClass_maybe x - ftc _ = Nothing - -lookupGhcDataCon dc = case isTupleDC dc of - Just n -> return $ tupleCon BoxedTuple n - Nothing -> lookupGhcDataCon' dc - -isTupleDC zs@('(':',':_) = Just $ length zs - 1 -isTupleDC _ = Nothing - - -lookupGhcDataCon' = lookupGhcThing "DataCon" fdc - where - fdc (ADataCon x) = Just x - fdc _ = Nothing - -wiredIn :: M.HashMap String Name -wiredIn = M.fromList $ {- tracePpr "wiredIn: " $ -} special ++ wiredIns - where wiredIns = [ (showPpr n, n) | thing <- wiredInThings, let n = getName thing ] - special = [ ("GHC.Integer.smallInteger", smallIntegerName) - , ("GHC.Num.fromInteger" , fromIntegerName ) ] - - -fixpointPrims = ["Pred", "Prop", "List", "Set_Set", "Set_sng", "Set_cup", "Set_cap" - ,"Set_dif", "Set_emp", "Set_mem", "Set_sub", "VV"] - -class Resolvable a where - resolve :: a -> BareM a - -instance Resolvable Qualifier where - resolve (Q n ps b) = Q n <$> mapM (secondM resolve) ps <*> resolve b - -instance Resolvable Pred where - resolve (PAnd ps) = PAnd <$> mapM resolve ps - resolve (POr ps) = POr <$> mapM resolve ps - resolve (PNot p) = PNot <$> resolve p - resolve (PImp p q) = PImp <$> resolve p <*> resolve q - resolve (PIff p q) = PIff <$> resolve p <*> resolve q - resolve (PBexp b) = PBexp <$> resolve b - resolve (PAtom r e1 e2) = PAtom r <$> resolve e1 <*> resolve e2 - resolve (PAll vs p) = PAll <$> mapM (secondM resolve) vs - <*> resolve p - resolve p = return p - -instance Resolvable Expr where - resolve (EVar s) = EVar <$> resolve s - resolve (EApp s es) = EApp <$> resolve s <*> es' - where es' = mapM resolve es - resolve (EBin o e1 e2) = EBin o <$> resolve e1 <*> resolve e2 - resolve (EIte p e1 e2) = EIte <$> resolve p <*> resolve e1 <*> resolve e2 - resolve (ECst x s) = ECst <$> resolve x <*> resolve s - resolve x = return x - -instance Resolvable Symbol where - resolve (S s) - | s `elem` fixpointPrims = return (S s) - | otherwise = do env <- gets (typeAliases.rtEnv) - case M.lookup s env of - Nothing | isCon s - -> do v <- lookupGhcVar s - let qs = symbol $ showPpr v - addSym (qs,v) - return qs - _ -> return (S s) - -instance Resolvable Sort where - resolve FInt = return FInt - resolve FNum = return FNum - resolve s@(FObj _) = return s --FObj . S <$> lookupName env m s - resolve s@(FVar _) = return s - resolve (FFunc i ss) = FFunc i <$> mapM resolve ss - resolve (FApp tc ss) - | tcs `elem` fixpointPrims = FApp tc <$> ss' - | otherwise = FApp <$> (stringFTycon.showPpr <$> lookupGhcTyCon tcs) - <*> ss' - where tcs = fTyconString tc - ss' = mapM resolve ss - -instance Resolvable (UReft Reft) where - resolve (U r p) = U <$> resolve r <*> resolve p - -instance Resolvable Reft where - resolve (Reft (s, ras)) = Reft . (s,) <$> mapM resolveRefa ras - where - resolveRefa (RConc p) = RConc <$> resolve p - resolveRefa kv = return kv - -instance Resolvable Predicate where - resolve (Pr pvs) = Pr <$> mapM resolve pvs - -instance (Resolvable t) => Resolvable (PVar t) where - resolve (PV n t as) = PV n t <$> mapM (third3M resolve) as - -instance Resolvable () where - resolve () = return () - -isCon (c:cs) = isUpper c -isCon [] = False - --------------------------------------------------------------------- ------- Predicate Types for WiredIns -------------------------------- --------------------------------------------------------------------- - -maxArity :: Arity -maxArity = 7 - -wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)]) -wiredTyDataCons = (concat tcs, concat dcs) - where - (tcs, dcs) = unzip l - l = [listTyDataCons] ++ map tupleTyDataCons [1..maxArity] - -listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)]) -listTyDataCons = ( [(c, TyConP [(RTV tyv)] [p] [0] [] (Just fsize))] - , [(nilDataCon , DataConP [(RTV tyv)] [p] [] lt) - , (consDataCon, DataConP [(RTV tyv)] [p] cargs lt)]) - where c = listTyCon - [tyv] = tyConTyVars c - t = {- TyVarTy -} rVar tyv :: RSort - fld = stringSymbol "fld" - x = stringSymbol "x" - xs = stringSymbol "xs" - p = PV (stringSymbol "p") t [(t, fld, EVar fld)] - px = (pdVarReft $ PV (stringSymbol "p") t [(t, fld, EVar x)]) - lt = rApp c [xt] [RMono [] $ pdVarReft p] top - xt = rVar tyv - xst = rApp c [RVar (RTV tyv) px] [RMono [] $ pdVarReft p] top - cargs = [(xs, xst), (x, xt)] - fsize = \x -> EApp (S "len") [EVar x] - -tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)]) -tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [0..(n-2)] [] Nothing)] - , [(dc, DataConP (RTV <$> tyvs) ps cargs lt)]) - where c = tupleTyCon BoxedTuple n - dc = tupleCon BoxedTuple n - tyvs@(tv:tvs) = tyConTyVars c - (ta:ts) = (rVar <$> tyvs) :: [RSort] - flds = mks "fld" - fld = stringSymbol "fld" - x1:xs = mks "x" - -- y = stringSymbol "y" - ps = mkps pnames (ta:ts) ((fld, EVar fld):(zip flds (EVar <$>flds))) - ups = uPVar <$> ps - pxs = mkps pnames (ta:ts) ((fld, EVar x1):(zip flds (EVar <$> xs))) - lt = rApp c (rVar <$> tyvs) (RMono [] . pdVarReft <$> ups) top - xts = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs - cargs = reverse $ (x1, rVar tv) : (zip xs xts) - pnames = mks_ "p" - mks x = (\i -> stringSymbol (x++ show i)) <$> [1..n] - mks_ x = (\i -> (x++ show i)) <$> [2..n] - - -pdVarReft = U top . pdVar - -mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ (stringSymbol <$> ns) ts fxs [(t, f, x)] [] -mkps _ _ _ = error "Bare : mkps" - -mkps_ [] _ _ _ ps = ps -mkps_ (n:ns) (t:ts) ((f, x):xs) args ps - = mkps_ ns ts xs (a:args) (p:ps) - where p = PV n t args - a = (t, f, x) -mkps_ _ _ _ _ _ = error "Bare : mkps_" - ------------------------------------------------------------------------- ------------------ Transforming Raw Strings using GHC Env --------------- ------------------------------------------------------------------------- - --- makeRTyConPs :: Reftable r => String -> M.HashMap TyCon RTyCon -> [RPVar] -> RRType r -> RRType r --- makeRTyConPs msg tyi πs t@(RApp c ts rs r) --- | null $ rTyConPs c --- = expandRApp tyi t --- | otherwise --- = RApp c {rTyConPs = findπ πs <$> rTyConPs c} ts rs r --- -- need type application???? --- where findπ πs π = findWithDefaultL (== π) πs (emsg π) --- emsg π = errorstar $ "Bare: out of scope predicate " ++ msg ++ " " ++ show π --- -- throwError $ "Bare: out of scope predicate" ++ show π --- --- --- makeRTyConPs _ _ _ t = t - - -ofBareType' :: (PPrint r, Reftable r) => String -> BRType r -> BareM (RRType r) -ofBareType' msg = wrapErr msg ofBareType - -ofBareType :: (PPrint r, Reftable r) => BRType r -> BareM (RRType r) -ofBareType (RVar a r) - = return $ RVar (stringRTyVar a) r -ofBareType (RFun x t1 t2 _) - = liftM2 (rFun x) (ofBareType t1) (ofBareType t2) -ofBareType (RAppTy t1 t2 _) - = liftM2 rAppTy (ofBareType t1) (ofBareType t2) -ofBareType (RAllE x t1 t2) - = liftM2 (RAllE x) (ofBareType t1) (ofBareType t2) -ofBareType (REx x t1 t2) - = liftM2 (REx x) (ofBareType t1) (ofBareType t2) -ofBareType (RAllT a t) - = liftM (RAllT (stringRTyVar a)) (ofBareType t) -ofBareType (RAllP π t) - = liftM2 RAllP (ofBPVar π) (ofBareType t) -ofBareType (RApp tc ts@[_] rs r) - | isList tc - = do tyi <- tcEnv <$> get - liftM2 (bareTCApp tyi r listTyCon) (mapM ofRef rs) (mapM ofBareType ts) -ofBareType (RApp tc ts rs r) - | isTuple tc - = do tyi <- tcEnv <$> get - liftM2 (bareTCApp tyi r c) (mapM ofRef rs) (mapM ofBareType ts) - where c = tupleTyCon BoxedTuple (length ts) -ofBareType (RApp tc ts rs r) - = do tyi <- tcEnv <$> get - liftM3 (bareTCApp tyi r) (lookupGhcTyCon tc) (mapM ofRef rs) (mapM ofBareType ts) -ofBareType (RCls c ts) - = liftM2 RCls (lookupGhcClass c) (mapM ofBareType ts) -ofBareType (ROth s) - = return $ ROth s -ofBareType t - = errorstar $ "Bare : ofBareType cannot handle " ++ show t - -ofRef (RPoly ss t) - = liftM2 RPoly (mapM ofSyms ss) (ofBareType t) -ofRef (RMono ss r) - = liftM (`RMono` r) (mapM ofSyms ss) - -ofSyms (x, t) - = liftM ((,) x) (ofBareType t) - --- TODO: move back to RefType -bareTCApp _ r c rs ts | length ts == tyConArity c - = if isTrivial t0 then t' else t - where t0 = rApp c ts rs top - t = rApp c ts rs r - t' = (expandRTypeSynonyms t0) `strengthen` r --- otherwise create an error --- create the error later to get better message -bareTCApp _ _ c rs ts = rApp c ts rs top - -expandRTypeSynonyms = ofType . expandTypeSynonyms . toType - -stringRTyVar = rTyVar . stringTyVar --- stringTyVarTy = TyVarTy . stringTyVar - -mkMeasureDCon :: Ms.MSpec t Symbol -> BareM (Ms.MSpec t DataCon) -mkMeasureDCon m = (forM (measureCtors m) $ \n -> (n,) <$> lookupGhcDataCon n) - >>= (return . mkMeasureDCon_ m) - -mkMeasureDCon_ :: Ms.MSpec t Symbol -> [(String, DataCon)] -> Ms.MSpec t DataCon -mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'} - where - m' = fmap tx m - cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m' - tx = mlookup (M.fromList ndcs) . symbolString - tx' = dataConSymbol - -measureCtors :: Ms.MSpec t Symbol -> [String] -measureCtors = sortNub . fmap (symbolString . Ms.ctor) . concat . M.elems . Ms.ctorMap - --- mkMeasureSort :: (PVarable pv, Reftable r) => Ms.MSpec (BRType pv r) bndr-> BareM (Ms.MSpec (RRType pv r) bndr) -mkMeasureSort (Ms.MSpec cm mm) - = liftM (Ms.MSpec cm) $ forM mm $ \m -> do - liftM (\s' -> m {Ms.sort = s'}) (ofBareType' (msg m) (Ms.sort m)) - where - msg m = berrMeasure (loc $ Ms.name m) (Ms.name m) (Ms.sort m) - - - ------------------------------------------------------------------------ ------------------------ Prop TyCon Definition ------------------------- ------------------------------------------------------------------------ - -propTyCon = stringTyCon 'w' 24 propConName --- propMeasure = (stringSymbolRaw propConName, FFunc - ------------------------------------------------------------------------ ----------------- Bare Predicate: DataCon Definitions ------------------ ------------------------------------------------------------------------ - -makeConTypes (name,spec) = inModule name $ makeConTypes' $ Ms.dataDecls spec - -makeConTypes' :: [DataDecl] -> BareM ([(TyCon, TyConP)], [[(DataCon, DataConP)]]) -makeConTypes' dcs = unzip <$> mapM ofBDataDecl dcs - -ofBDataDecl :: DataDecl -> BareM ((TyCon, TyConP), [(DataCon, DataConP)]) -ofBDataDecl (D tc as ps cts pos sfun) - = do πs <- mapM ofBPVar ps - tc' <- lookupGhcTyCon tc - cts' <- mapM (ofBDataCon (berrDataDecl pos tc πs) tc' αs ps πs) cts - let tys = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp] - let initmap = zip (uPVar <$> πs) [0..] - let varInfo = concatMap (getPsSig initmap True) tys - let cov = [i | (i, b)<- varInfo, b, i >=0] - let contr = [i | (i, b)<- varInfo, not b, i >=0] - return ((tc', TyConP αs πs cov contr sfun), cts') - where αs = fmap (RTV . stringTyVar) as - -- cpts = fmap (second (fmap (second (mapReft ur_pred)))) cts - -getPsSig m pos (RAllT _ t) - = getPsSig m pos t -getPsSig m pos (RApp _ ts rs r) - = addps m pos r ++ concatMap (getPsSig m pos) ts - ++ concatMap (getPsSigPs m pos) rs -getPsSig m pos (RVar _ r) - = addps m pos r -getPsSig m pos (RAppTy t1 t2 r) - = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2 -getPsSig m pos (RFun _ t1 t2 r) - = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1 - - -getPsSigPs m pos (RMono _ r) = addps m pos r -getPsSigPs m pos (RPoly _ t) = getPsSig m pos t - -addps m pos (U _ ps) = (flip (,)) pos . f <$> pvars ps - where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar --- ofBPreds = fmap (fmap stringTyVarTy) -dataDeclTyConP d - = do let αs = fmap (RTV . stringTyVar) (tycTyVars d) -- as - πs <- mapM ofBPVar (tycPVars d) -- ps - tc' <- lookupGhcTyCon (tycName d) -- tc - return $ (tc', TyConP αs πs) - --- ofBPreds = fmap (fmap stringTyVarTy) -ofBPVar :: PVar BSort -> BareM (PVar RSort) -ofBPVar = mapM_pvar ofBareType - -mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b) -mapM_pvar f (PV x t txys) - = do t' <- f t - txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys - return $ PV x t' txys' - -ofBDataCon msg tc αs ps πs (c, xts) - = do c' <- wrapErr msg lookupGhcDataCon c - ts' <- mapM (mkSpecType' msg ps) ts - let t0 = rApp tc rs (RMono [] . pdVarReft <$> πs) top - return $ (c', DataConP αs πs (reverse (zip xs' ts')) t0) - where - (xs, ts) = unzip xts - xs' = map stringSymbol xs - rs = [rVar α | RTV α <- αs] -- [RVar α pdTrue | α <- αs] - ------------------------------------------------------------------------ ----------------- Bare Predicate: RefTypes ----------------------------- ------------------------------------------------------------------------ - -txParams f πs t = mapReft (f (txPvar (predMap πs t))) t - -txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar -txPvar m π = π { pargs = args' } - where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π) - | otherwise = pargs π' - π' = fromMaybe (errorstar err) $ M.lookup (pname π) m - err = "Bare.replaceParams Unbound Predicate Variable: " ++ show π - -predMap πs t = Ex.assert (M.size xπm == length xπs) xπm - where xπm = M.fromList xπs - xπs = [(pname π, π) | π <- πs ++ rtypePredBinds t] - -rtypePredBinds = map uPVar . snd3 . bkUniv - --- rtypePredBinds t = everything (++) ([] `mkQ` grab) t --- where grab ((RAllP pv _) :: BRType RPVar RPredicate) = [pv] --- grab _ = [] - ----------------------------------------------------------------------------------------------- ------ Checking GhcSpec ----------------------------------------------------------------------- ----------------------------------------------------------------------------------------------- - -checkGhcSpec :: (GhcSpec, [Ms.Measure SpecType DataCon]) -> Either [Error] GhcSpec - -checkGhcSpec (sp, ms) = applyNonNull (Right sp) Left errors - where - errors = mapMaybe (checkBind "variable" emb env) (tySigs sp) - ++ mapMaybe (checkBind "constructor" emb env) (dcons sp) - ++ mapMaybe (checkBind "measure" emb env) (measSpec sp) - ++ mapMaybe (checkInv emb env) (invariants sp) - ++ checkMeasures emb env ms - ++ mapMaybe checkMismatch (tySigs sp) - ++ checkDuplicate (tySigs sp) - dcons spec = mapSnd (Loc dummyPos) <$> dataConSpec (dconsP spec) - emb = tcEmbeds sp - env = ghcSpecEnv sp - measSpec sp = [(x, uRType <$> t) | (x, t) <- meas sp] - --- specError = errorstar --- . render --- . vcat --- . punctuate (text "\n----\n") --- . (text "Alas, errors found in specification..." :) - -checkInv :: TCEmb TyCon -> SEnv SortedReft -> Located SpecType -> Maybe Error -checkInv emb env t = checkTy err emb env (val t) - where - err = ErrInvt (sourcePosSrcSpan $ loc t) (val t) - - -checkBind :: (PPrint v) => String -> TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error -checkBind s emb env (v, Loc l t) = checkTy msg emb env t - where - msg = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t - -checkTy :: (Doc -> Error) -> TCEmb TyCon -> SEnv SortedReft -> SpecType -> Maybe Error -checkTy mkE emb env t = mkE <$> checkRType emb env t - -checkDuplicate :: [(Var, Located SpecType)] -> [Error] -checkDuplicate xts = mkErr <$> dups - where - mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (sourcePosSrcSpan . loc <$> ts) - dups = [z | z@(x, t1:t2:_) <- M.toList $ group xts ] - - -checkMismatch :: (Var, Located SpecType) -> Maybe Error -checkMismatch (x, t) = if ok then Nothing else Just err - where - ok = tyCompat x (val t) - err = errTypeMismatch x t - -tyCompat x t = lhs == rhs - where - lhs :: RSort = toRSort t - rhs :: RSort = ofType $ varType x - msg = printf "tyCompat: l = %s r = %s" (showpp lhs) (showpp rhs) - -ghcSpecEnv sp = fromListSEnv binds - where - emb = tcEmbeds sp - binds = [(x, rSort t) | (x, Loc _ t) <- meas sp] - ++ [(varSymbol v, rSort t) | (v, Loc _ t) <- ctor sp] - ++ [(x , vSort v) | (x, v) <- freeSyms sp, isConLikeId v] - rSort = rTypeSortedReft emb - vSort = rSort . varRType - varRType :: Var -> RRType () - varRType = ofType . varType - -errTypeMismatch :: Var -> Located SpecType -> Error -errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (val t) - -------------------------------------------------------------------------------------- --- | This function checks if a type is malformed in a given environment ------------- -------------------------------------------------------------------------------------- - -------------------------------------------------------------------------------------- -checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType r -> Maybe Doc -------------------------------------------------------------------------------------- - -checkRType emb env t = efoldReft cb (rTypeSortedReft emb) f env Nothing t - where - cb c ts = classBinds (RCls c ts) - f env me r err = err <|> checkReft env emb me r - -checkReft :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType r) -> r -> Maybe Doc -checkReft env emb Nothing _ = Nothing -- RMono / Ref case, not sure how to check these yet. -checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env r - where - r = rTypeSortedReft emb t - dr = text "Sort Error in Refinement:" <+> pprint r - --- DONT DELETE the below till we've added pred-checking as well --- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t) --- where xs = fromMaybe [] $ params <$> stripRTypeBase t - --- checkSig env (x, t) --- = case filter (not . (`S.member` env)) (freeSymbols t) of --- [] -> True --- ys -> errorstar (msg ys) --- where --- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t) - - -------------------------------------------------------------------------------- ------------------- Replace Predicate Arguments With Existentials ------------- -------------------------------------------------------------------------------- - -data ExSt = ExSt { fresh :: Int - , emap :: M.HashMap Symbol (RSort, Expr) - , pmap :: M.HashMap Symbol RPVar - } - --- | Niki: please write more documentation for this, maybe an example? --- I can't really tell whats going on... (RJ) - -txExpToBind :: SpecType -> SpecType -txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs) - where πs = M.fromList [(pname p, p) | p <- snd3 $ bkUniv t ] - -expToBindT :: SpecType -> State ExSt SpecType -expToBindT (RVar v r) - = expToBindRef r >>= addExists . RVar v -expToBindT (RFun x t1 t2 r) - = do t1' <- expToBindT t1 - t2' <- expToBindT t2 - expToBindRef r >>= addExists . RFun x t1' t2' -expToBindT (RAllT a t) - = liftM (RAllT a) (expToBindT t) -expToBindT (RAllP p t) - = liftM (RAllP p) (expToBindT t) -expToBindT (RApp c ts rs r) - = do ts' <- mapM expToBindT ts - rs' <- mapM expToBindReft rs - expToBindRef r >>= addExists . RApp c ts' rs' -expToBindT (RCls c ts) - = liftM (RCls c) (mapM expToBindT ts) -expToBindT (RAppTy t1 t2 r) - = do t1' <- expToBindT t1 - t2' <- expToBindT t2 - expToBindRef r >>= addExists . RAppTy t1' t2' -expToBindT t - = return t - -expToBindReft :: Ref RSort RReft (SpecType) -> State ExSt (Ref RSort RReft SpecType) -expToBindReft (RPoly s t) = liftM (RPoly s) (expToBindT t) -expToBindReft (RMono s r) = liftM (RMono s) (expToBindRef r) - -getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr)) -getBinds - = do bds <- emap <$> get - modify $ \st -> st{emap = M.empty} - return bds - -addExists t = liftM (M.foldlWithKey' addExist t) getBinds - -addExist t x (tx, e) = RAllE x t' t - where t' = (ofRSort tx) `strengthen` uTop r - r = Reft (vv Nothing, [RConc (PAtom Eq (EVar (vv Nothing)) e)]) - -expToBindRef :: UReft r -> State ExSt (UReft r) -expToBindRef (U r (Pr p)) - = mapM expToBind p >>= return . U r . Pr - -expToBind :: UsedPVar -> State ExSt UsedPVar -expToBind p - = do Just π <- liftM (M.lookup (pname p)) (pmap <$> get) - let pargs0 = zip (pargs p) (fst3 <$> pargs π) - pargs' <- mapM expToBindParg pargs0 - return $ p{pargs = pargs'} - -expToBindParg :: (((), Symbol, Expr), RSort) -> State ExSt ((), Symbol, Expr) -expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s') - -expToBindExpr :: Expr -> RRType () -> State ExSt Expr -expToBindExpr e@(EVar (S (c:_))) _ | isLower c - = return e -expToBindExpr e t - = do s <- freshSymbol - modify $ \st -> st{emap = M.insert s (t, e) (emap st)} - return $ EVar s - -freshSymbol :: State ExSt Symbol -freshSymbol - = do n <- fresh <$> get - modify $ \s -> s{fresh = n+1} - return $ S $ "ex#" ++ show n - - -------------------------------------------------------------------------------------- --- | Tasteful Error Messages -------------------------------------------------------- -------------------------------------------------------------------------------------- - -berrDataDecl l c πs = printf "[%s]\nCannot convert data type %s with πs = %s" - (showpp l) (showpp c) (showpp πs) -berrVarSpec l v b = printf "[%s]\nCannot convert\n %s :: %s" - (showpp l) (showpp v) (showpp b) -berrInvariant l i = printf "[%s]\nCannot convert invariant\n %s" - (showpp l) (showpp i) -berrMeasure l x t = printf "[%s]\nCannot convert measure %s :: %s" - (showpp l) (showpp x) (showpp t) - --- berrUnknownVar x = printf "[%s]\nSpecification for unknown Variable : %s" --- (showpp $ loc x) (showpp $ val x) --- --- berrUnknownTyCon x = printf "[%s]\nSpecification for unknown TyCon : %s" --- (showpp $ loc x) (showpp $ val x) -berrUnknownTyCon = berrUnknown "TyCon" -berrUnknownVar = berrUnknown "Variable" - -berrUnknown :: (PPrint a) => String -> Located a -> String -berrUnknown thing x = printf "[%s]\nSpecification for unknown %s : %s" - thing (showpp $ loc x) (showpp $ val x) - - - - - - --- berrUnknownTyCon z = printf "Specification for unknown variable: %s defined at: %s" --- (showpp $ symbolString $ val z) (showpp $ loc z) diff --git a/Language/Haskell/Liquid/CTags.hs b/Language/Haskell/Liquid/CTags.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/CTags.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE TupleSections #-} --- | This module contains the code for generating "tags" for constraints --- based on their source, i.e. the top-level binders under which the --- constraint was generated. These tags are used by fixpoint to --- prioritize constraints by the "source-level" function. - -module Language.Haskell.Liquid.CTags ( - -- * Type for constraint tags - TagKey, TagEnv - - -- * Default tag value - , defaultTag - - -- * Constructing @TagEnv@ - , makeTagEnv - - -- * Accessing @TagEnv@ - , getTag, memTagEnv - -) where - -import Var -import CoreSyn - --- import qualified Data.List as L -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as M -import qualified Data.Graph as G - -import Language.Fixpoint.Misc (mapSnd, traceShow) -import Language.Fixpoint.Types (Tag) -import Language.Haskell.Liquid.GhcInterface (freeVars) - --- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list - -type TagKey = Var -type TagEnv = M.HashMap TagKey Tag - --- TODO: use the "callgraph" SCC to do this numbering. - -defaultTag :: Tag -defaultTag = [0] - -memTagEnv :: TagKey -> TagEnv -> Bool -memTagEnv = M.member - -makeTagEnv :: [CoreBind] -> TagEnv -makeTagEnv = M.map (:[]) . callGraphRanks . makeCallGraph - --- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns - -getTag :: TagKey -> TagEnv -> Tag -getTag = M.lookupDefault defaultTag - ------------------------------------------------------------------------------------------------------- - -type CallGraph = [(Var, [Var])] -- caller-callee pairs - -callGraphRanks :: CallGraph -> M.HashMap Var Int --- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg - -callGraphRanks = M.fromList . concat . index . mkScc - where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg] - index = zipWith (\i -> map (, i) . G.flattenSCC) [1..] - -makeCallGraph :: [CoreBind] -> CallGraph -makeCallGraph cbs = mapSnd calls `fmap` xes - where xes = concatMap bindEqns cbs - xs = S.fromList $ map fst xes - calls = filter (`S.member` xs) . freeVars S.empty - -bindEqns (NonRec x e) = [(x, e)] -bindEqns (Rec xes) = xes - - diff --git a/Language/Haskell/Liquid/CmdLine.hs b/Language/Haskell/Liquid/CmdLine.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/CmdLine.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE BangPatterns #-} - --- | 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 --- here. The idea should be to report the error, the source position that --- causes it, generate a suitable .json file and then exit. - - -module Language.Haskell.Liquid.CmdLine ( - -- * Get Command Line Configuration - getOpts - - -- * Update Configuration With Pragma - , withPragmas - - -- * Exit Function - , exitWithResult - - -- * Extra Outputs - , Output (..) -) where - -import Control.DeepSeq -import Control.Monad -import Control.Applicative ((<$>)) - -import Data.List (foldl') -import Data.Maybe -import Data.Monoid -import qualified Data.HashMap.Strict as M - -import System.FilePath (dropFileName) -import System.Environment (withArgs) -import System.Console.CmdArgs hiding (Loud) -import System.Console.CmdArgs.Verbosity (whenLoud) - -import Language.Fixpoint.Misc -import Language.Fixpoint.Files -import Language.Fixpoint.Names (dropModuleNames) -import Language.Fixpoint.Types hiding (config) -import Language.Fixpoint.Config hiding (config, Config) -import Language.Haskell.Liquid.Annotate -import Language.Haskell.Liquid.Misc -import Language.Haskell.Liquid.PrettyPrint -import Language.Haskell.Liquid.Types hiding (config, typ) - -import Name -import SrcLoc (SrcSpan) -import Text.PrettyPrint.HughesPJ - - ---------------------------------------------------------------------------------- --- Parsing Command Line---------------------------------------------------------- ---------------------------------------------------------------------------------- - -config = Config { - files - = def &= typ "TARGET" - &= args - &= typFile - - , idirs - = def &= typDir - &= help "Paths to Spec Include Directory " - - , diffcheck - = def - &= help "Incremental Checking: only check changed binders" - - , binders - = def &= help "Check a specific set of binders" - - , nofalse - = def &= help "Remove false predicates from the refinements" - - , noPrune - = def &= help "Disable prunning unsorted Predicates" - &= name "no-prune-unsorted" - - , notermination - = def &= help "Disable Termination Check" - &= name "no-termination-check" - - , totality - = def &= help "Check totality" - - , smtsolver - = def &= help "Name of SMT-Solver" - - , noCheckUnknown - = def &= explicit - &= name "no-check-unknown" - &= help "Don't complain about specifications for unexported and unused values " - - , maxParams - = 2 &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)" - - -- , verbose - -- = def &= help "Generate Verbose Output" - -- &= name "verbose-output" - - } &= verbosity - &= program "liquid" - &= help "Refinement Types for Haskell" - &= summary copyright - &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell" - , "" - , "To check a Haskell file foo.hs, type:" - , " liquid foo.hs " - ] - -getOpts :: IO Config -getOpts = do md <- cmdArgs config - putStrLn $ copyright - whenLoud $ putStrLn $ "liquid " ++ show args ++ "\n" - mkOpts md - -copyright = "LiquidHaskell © Copyright 2009-13 Regents of the University of California. All Rights Reserved.\n" - -mkOpts :: Config -> IO Config -mkOpts md - = do files' <- sortNub . concat <$> mapM getHsTargets (files md) - idirs' <- if null (idirs md) then single <$> getIncludeDir else return (idirs md) - return $ md { files = files' } { idirs = map dropFileName files' ++ idirs' } - -- tests fail if you flip order of idirs' - ---------------------------------------------------------------------------------------- --- | Updating options ---------------------------------------------------------------------------------------- - ---------------------------------------------------------------------------------------- -withPragmas :: Config -> [Located String] -> IO Config ---------------------------------------------------------------------------------------- -withPragmas = foldM withPragma - -withPragma :: Config -> Located String -> IO Config -withPragma c s = (c `mappend`) <$> parsePragma s - -parsePragma :: Located String -> IO Config -parsePragma s = withArgs [val s] $ cmdArgs config - ---------------------------------------------------------------------------------------- --- | Monoid instances for updating options ---------------------------------------------------------------------------------------- - -instance Monoid Config where - mempty = Config def def def def def def def def def 2 def - mappend c1 c2 = Config (sortNub $ files c1 ++ files c2) - (sortNub $ idirs c1 ++ idirs c2) - (diffcheck c1 || diffcheck c2) - (sortNub $ binders c1 ++ binders c2) - (noCheckUnknown c1 || noCheckUnknown c2) - (nofalse c1 || nofalse c2) - (notermination c1 || notermination c2) - (totality c1 || totality c2) - (noPrune c1 || noPrune c2) - (maxParams c1 `max` maxParams c2) - (smtsolver c1 `mappend` smtsolver c2) - -instance Monoid SMTSolver where - mempty = def - mappend s1 s2 - | s1 == s2 = s1 - | s2 == def = s1 - | otherwise = s2 - - ------------------------------------------------------------------------- --- | Exit Function ----------------------------------------------------- ------------------------------------------------------------------------- - -exitWithResult :: FilePath -> Maybe Output -> ErrorResult -> IO ErrorResult -exitWithResult target o r = writeExit target r $ fromMaybe emptyOutput o - -writeExit target r out = do {-# SCC "annotate" #-} annotate target r (o_soln out) (o_annot out) - donePhase Loud "annotate" - let rs = showFix r - writeResult (colorResult r) r - writeFile (extFileName Result target) rs - writeWarns $ o_warns out - writeCheckVars $ o_vars out - return r - -writeWarns [] = return () -writeWarns ws = colorPhaseLn Angry "Warnings:" "" >> putStrLn (unlines ws) - -writeCheckVars Nothing = return () -writeCheckVars (Just ns) = colorPhaseLn Loud "Checked Binders:" "" >> forM_ ns (putStrLn . dropModuleNames . showpp) - -writeResult c = mapM_ (writeDoc c) . resDocs - where - writeDoc c = writeBlock c . lines . render - writeBlock c (s:ss) = do {colorPhaseLn c s ""; forM_ ss putStrLn } - writeBlock c _ = return () - - -resDocs Safe = [text "SAFE"] -resDocs (Crash xs s) = text ("CRASH: " ++ s) : pprManyOrdered "CRASH: " xs -resDocs (Unsafe xs) = pprManyOrdered "UNSAFE: " xs -resDocs (UnknownError d) = [text "PANIC: Unexpected Error: " <+> d, reportUrl] -reportUrl = text "Please submit a bug report at:" - $+$ text " https://github.com/ucsd-progsys/liquidhaskell" - -instance Fixpoint (FixResult Error) where - toFix = vcat . resDocs - - -- vcat [[String]] - -- toFix Safe = text "SAFE" - -- toFix (UnknownError d) = text "Unknown Error!" - -- toFix (Crash xs msg) = vcat $ text "Crash!" : pprManyOrdered "CRASH: " xs ++ [parens (text msg)] - -- toFix (Unsafe xs) = vcat $ text "Unsafe:" : pprManyOrdered "WARNING: " xs - - ------------------------------------------------------------------------- --- | Stuff To Output --------------------------------------------------- ------------------------------------------------------------------------- - -data Output = O { o_vars :: Maybe [Name] - , o_warns :: [String] - , o_soln :: FixSolution - , o_annot :: !(AnnInfo Annot) - } - -emptyOutput = O Nothing [] M.empty mempty diff --git a/Language/Haskell/Liquid/Constraint.hs b/Language/Haskell/Liquid/Constraint.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Constraint.hs +++ /dev/null @@ -1,1415 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | This module defines the representation of Subtyping and WF Constraints, and --- the code for syntax-directed constraint generation. - -module Language.Haskell.Liquid.Constraint ( - - -- * Constraint information output by generator - CGInfo (..) - - -- * Function that does the actual generation - , generateConstraints - - -- * Project Constraints to Fixpoint Format - , cgInfoFInfo , cgInfoFInfoBot, cgInfoFInfoKvars - - -- * KVars in constraints, for debug purposes - -- , kvars, kvars' - ) where - -import CoreSyn -import SrcLoc -import Type -- (coreEqType) -import PrelNames -import qualified TyCon as TC - -import TypeRep -import Class (Class, className) -import Var -import Id -import Name (getSrcSpan) -import Text.PrettyPrint.HughesPJ - -import Control.Monad.State - -import Control.Applicative ((<$>)) -import Control.Exception.Base - -import Data.Monoid (mconcat) -import Data.Maybe (fromJust, isJust, fromMaybe, catMaybes) -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.List as L -import Data.Bifunctor -import Data.List (foldl') - -import Text.Printf - -import qualified Language.Haskell.Liquid.CTags as Tg -import qualified Language.Fixpoint.Types as F -import Language.Fixpoint.Names (dropModuleNames) -import Language.Fixpoint.Sort (pruneUnsortedReft) - -import Language.Haskell.Liquid.Fresh - -import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars) -import Language.Haskell.Liquid.Bare -import Language.Haskell.Liquid.Annotate -import Language.Haskell.Liquid.GhcInterface -import Language.Haskell.Liquid.RefType -import Language.Haskell.Liquid.PredType hiding (freeTyVars) -import Language.Haskell.Liquid.Predicates -import Language.Haskell.Liquid.GhcMisc (isInternal, collectArguments, getSourcePos, pprDoc, tickSrcSpan, hasBaseTypeVar, showPpr) -import Language.Haskell.Liquid.Misc -import Language.Fixpoint.Misc -import Language.Haskell.Liquid.Qualifier -import Control.DeepSeq - - ------------------------------------------------------------------------ -------------- Constraint Generation: Toplevel ------------------------- ------------------------------------------------------------------------ - -generateConstraints :: GhcInfo -> CGInfo -generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info - where - act = consAct (info {cbs = fst pds}) (snd pds) - pds = generatePredicates info - cfg = config $ spec info - -consAct info penv - = do γ <- initEnv info penv - foldM consCBTop γ (cbs info) - hcs <- hsCs <$> get - hws <- hsWfs <$> get - fcs <- concat <$> mapM splitC hcs - fws <- concat <$> mapM splitW hws - modify $ \st -> st { fixCs = fcs } { fixWfs = fws } - -initEnv :: GhcInfo -> F.SEnv PrType -> CG CGEnv -initEnv info penv - = do let tce = tcEmbeds $ spec info - defaults <- forM (impVars info) $ \x -> liftM (x,) (trueTy $ varType x) - tyi <- tyConInfo <$> get - let f0 = grty info -- asserted refinements (for defined vars) - f0' <- grtyTop info -- default TOP reftype (for exported vars without spec) - let f1 = defaults -- default TOP reftype (for all vars) - f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars) - f3 <- refreshArgs' $ ctor' $ spec info -- constructor refinements (for measures) - let bs = (map (unifyts' tce tyi penv)) <$> [f0 ++ f0', f1, f2, f3] - lts <- lits <$> get - let tcb = mapSnd (rTypeSort tce ) <$> concat bs - let γ0 = measEnv (spec info) penv (head bs) (cbs info) (tcb ++ lts) - foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat bs] - where refreshArgs' = mapM (mapSndM refreshArgs) - -- where tce = tcEmbeds $ spec info - -ctor' = map (mapSnd val) . ctor - -unifyts' tce tyi penv = (second (addTyConInfo tce tyi)) . (unifyts penv) - -unifyts penv (x, t) = (x', unify pt t) - where pt = F.lookupSEnv x' penv - x' = varSymbol x - -measEnv sp penv xts cbs lts - = CGE { loc = noSrcSpan - , renv = fromListREnv $ second (uRType . val) <$> meas sp - , syenv = F.fromListSEnv $ freeSyms sp - , penv = penv - , fenv = initFEnv (lts ++ (second (rTypeSort tce . val) <$> meas sp)) - , recs = S.empty - , invs = mkRTyConInv $ invariants sp - , grtys = fromListREnv xts - , emb = tce - , tgEnv = Tg.makeTagEnv cbs - , tgKey = Nothing - , trec = Nothing - , lcb = M.empty - } - where tce = tcEmbeds sp - -assm = assm_grty impVars -grty = assm_grty defVars - -assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] - where - 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] - where - topVs = filter isTop $ defVars info - isTop v = isExportedId v && not (v `S.member` useVs) && not (v `S.member` sigVs) - useVs = S.fromList $ useVars info - sigVs = S.fromList $ [v | (v,_) <- tySigs $ spec info] - - ------------------------------------------------------------------------- --- | Helpers: Reading/Extending Environment Bindings ------------------- ------------------------------------------------------------------------- - -data FEnv = FE { fe_binds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment - , fe_env :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment - } - -insertFEnv (FE benv env) ((x, t), i) - = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env) - -insertsFEnv = L.foldl' insertFEnv - -initFEnv init = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ init) - -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) - , fenv :: !FEnv -- ^ Fixpoint Environment - , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations) - , invs :: !RTyConInv -- ^ Datatype invariants - , grtys :: !REnv -- ^ Top-level variables with (assert)-guarantees to verify - , emb :: F.TCEmb TC.TyCon -- ^ How to embed GHC Tycons into fixpoint sorts - , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag - , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder - , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints - , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked - } -- deriving (Data, Typeable) - -instance PPrint CGEnv where - pprint = pprint . renv - -instance Show CGEnv where - show = showpp - -getTag :: CGEnv -> F.Tag -getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ) - -getPrType :: CGEnv -> F.Symbol -> Maybe PrType -getPrType γ x = F.lookupSEnv x (penv γ) - -setLoc :: CGEnv -> SrcSpan -> CGEnv -γ `setLoc` src - | isGoodSrcSpan src = γ { loc = src } - | otherwise = γ - -withRecs :: CGEnv -> [Var] -> CGEnv -withRecs γ xs = γ { recs = foldl' (flip S.insert) (recs γ) xs } - -withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'} - where γ' = γ `withRecs` (fst <$> xts) - trec' = fromMaybe M.empty $ trec γ - xts' = mapFst varSymbol <$> xts - -setBind :: CGEnv -> Tg.TagKey -> CGEnv -setBind γ k - | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k } - | otherwise = γ - - -isGeneric :: RTyVar -> SpecType -> Bool -isGeneric α t = all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t) - where classConstrs t = [(c, α') | (c, ts) <- tyClasses t - , t' <- ts - , α' <- freeTyVars t'] - isOrd = (ordClassName ==) . className - isEq = (eqClassName ==) . className - --- isBase :: RType a -> Bool -isBase (RAllP _ t) = isBase t -isBase (RVar _ _) = True -isBase (RApp _ ts _ _) = all isBase ts -isBase (RFun _ t1 t2 _) = isBase t1 && isBase t2 -isBase _ = False - ------------------------------------------------------------------ -------------------- Constraints: Types -------------------------- ------------------------------------------------------------------ - -data SubC = SubC { senv :: !CGEnv - , lhs :: !SpecType - , rhs :: !SpecType - } - -data WfC = WfC !CGEnv !SpecType - -- deriving (Data, Typeable) - -type FixSubC = F.SubC Cinfo -type FixWfC = F.WfC Cinfo - -instance PPrint SubC where - pprint c = pprint (senv c) - $+$ ((text " |- ") <+> ( (pprint (lhs c)) - $+$ text "<:" - $+$ (pprint (rhs c)))) - -instance PPrint WfC where - pprint (WfC w r) = pprint w <> text " |- " <> pprint r - - ------------------------------------------------------------- -------------------- Constraint Splitting ------------------- ------------------------------------------------------------- - -splitW :: WfC -> CG [FixWfC] - -splitW (WfC γ t@(RFun x t1 t2 _)) - = do ws <- bsplitW γ t - ws' <- splitW (WfC γ t1) - γ' <- (γ, "splitW") += (x, t1) - ws'' <- splitW (WfC γ' t2) - return $ ws ++ ws' ++ ws'' - -splitW (WfC γ t@(RAppTy t1 t2 _)) - = do ws <- bsplitW γ t - ws' <- splitW (WfC γ t1) - ws'' <- splitW (WfC γ t2) - return $ ws ++ ws' ++ ws'' - -splitW (WfC γ (RAllT _ r)) - = splitW (WfC γ r) - -splitW (WfC γ (RAllP _ r)) - = splitW (WfC γ r) - -splitW (WfC γ t@(RVar _ _)) - = bsplitW γ t - -splitW (WfC _ (RCls _ _)) - = return [] - -splitW (WfC γ t@(RApp _ ts rs _)) - = do ws <- bsplitW γ t - γ' <- γ `extendEnvWithVV` t - ws' <- concat <$> mapM splitW (map (WfC γ') ts) - ws'' <- concat <$> mapM (rsplitW γ) rs - return $ ws ++ ws' ++ ws'' - -splitW (WfC _ t) - = errorstar $ "splitW cannot handle: " ++ showpp t - -rsplitW _ (RMono _ _) - = errorstar "Constrains: rsplitW for RMono" -rsplitW γ (RPoly ss t0) - = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss] - splitW $ WfC γ' t0 - -bsplitW :: CGEnv -> SpecType -> CG [FixWfC] -bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t - -bsplitW' γ t pflag - | F.isNonTrivialSortedReft r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci] - | otherwise = [] - where - r' = rTypeSortedReft' pflag γ t - ci = Ci (loc γ) Nothing - -mkSortedReft tce = F.RR . rTypeSort tce - ------------------------------------------------------------- -splitC :: SubC -> CG [FixSubC] ------------------------------------------------------------- - -splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2 - = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx) - splitC (SubC γ' t1 t2) - -splitC (SubC γ t1 (REx x tx t2)) - = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx) - let xs = grapBindsWithType tx γ - let t2' = splitExistsCases x xs tx t2 - splitC (SubC γ' t1 t2') - --- existential at the left hand side is treated like forall -splitC (SubC γ (REx x tx t1) t2) - = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx) - splitC (SubC γ' t1 t2) - -splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2 - = do γ' <- (γ, "addExBind 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) - -splitC (SubC γ t1 (RAllE x tx t2)) - = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx) - splitC (SubC γ' t1 t2) - -splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) - = do cs <- bsplitC γ t1 t2 - cs' <- splitC (SubC γ r2 r1) - γ' <- (γ, "splitC") += (x2, r2) - let r1x2' = r1' `F.subst1` (x1, F.EVar x2) - cs'' <- splitC (SubC γ' r1x2' r2') - return $ cs ++ cs' ++ cs'' - -splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) - = do cs <- bsplitC γ t1 t2 - cs' <- splitC (SubC γ r1 r2) - cs'' <- splitC (SubC γ r1' r2') - return $ cs ++ cs' ++ cs'' - -splitC (SubC γ t1 (RAllP p t)) - = splitC $ SubC γ t1 t' - where t' = fmap (replacePredsWithRefs su) t - su = (uPVar p, pVartoRConc p) - -splitC (SubC _ t1@(RAllP _ _) t2) - = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2 --- = splitC $ SubC γ t' t2 --- where t' = fmap (replacePredsWithRefs su) t --- su = (uPVar p, pVartoRConc p) - -splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2)) - | α1 == α2 - = splitC $ SubC γ t1 t2 - | otherwise - = splitC $ SubC γ t1 t2' - where t2' = subsTyVar_meet' (α2, RVar α1 F.top) t2 - -splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)) - = do (t1',t2') <- unifyVV t1 t2 - cs <- bsplitC γ t1' t2' - γ' <- γ `extendEnvWithVV` t1' - let RApp c t1s r1s _ = t1' - let RApp c' t2s r2s _ = t2' - let tyInfo = rTyConInfo c - cscov <- splitCIndexed γ' t1s t2s $ covariantTyArgs tyInfo - cscon <- splitCIndexed γ' t2s t1s $ contravariantTyArgs tyInfo - cscov' <- rsplitCIndexed γ' r1s r2s $ covariantPsArgs tyInfo - cscon' <- rsplitCIndexed γ' r2s r1s $ contravariantPsArgs tyInfo - return $ cs ++ cscov ++ cscon ++ cscov' ++ cscon' - -splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) - | a1 == a2 - = bsplitC γ t1 t2 - -splitC (SubC _ (RCls c1 _) (RCls c2 _)) | c1 == c2 - = return [] - -splitC c@(SubC _ t1 t2) - = errorstar $ "(Another Broken Test!!!) splitc unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2 - -splitCIndexed γ t1s t2s indexes - = concatMapM splitC (zipWith (SubC γ) t1s' t2s') - where t1s' = (L.!!) t1s <$> indexes - t2s' = (L.!!) t2s <$> indexes - -rsplitCIndexed γ t1s t2s indexes - = concatMapM (rsplitC γ) (safeZip "rsplitC" t1s' t2s') - where t1s' = (L.!!) t1s <$> indexes - t2s' = (L.!!) t2s <$> indexes - - -bsplitC γ t1 t2 = pruneRefs <$> get >>= return . bsplitC' γ t1 t2 - -bsplitC' γ t1 t2 pflag - | F.isFunctionSortedReft r1' && F.isNonTrivialSortedReft r2' - = [F.subC γ' F.PTrue (r1' {F.sr_reft = F.top}) r2' Nothing tag ci] - | F.isNonTrivialSortedReft r2' - = [F.subC γ' F.PTrue r1' r2' Nothing tag ci] - | otherwise - = [] - where - γ' = fe_binds $ fenv γ - r1' = rTypeSortedReft' pflag γ t1 - r2' = rTypeSortedReft' pflag γ t2 - ci = Ci src err - tag = getTag γ - err = Just $ ErrSubType src (text "subtype") t1 t2 - src = loc γ - -unifyVV t1@(RApp c1 _ _ _) t2@(RApp c2 _ _ _) - = do vv <- (F.vv . Just) <$> fresh - return $ (shiftVV t1 vv, (shiftVV t2 vv) ) -- {rt_pargs = r2s'}) - -rsplitC _ (RMono _ _, RMono _ _) - = errorstar "RefTypes.rsplitC on RMono" - -rsplitC γ (t1@(RPoly s1 r1), t2@(RPoly s2 r2)) - = do γ' <- foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2] - splitC (SubC γ' (F.subst su r1) r2) - where su = F.mkSubst [(x, F.EVar y) | (x, y) <- zip (fst <$> s1) (fst <$> s2)] - -rsplitC _ _ - = errorstar "rsplit Rpoly - RMono" - ------------------------------------------------------------ --------------------- Generation: Types -------------------- ------------------------------------------------------------ - -data CGInfo = CGInfo { hsCs :: ![SubC] - , hsWfs :: ![WfC] - , fixCs :: ![FixSubC] - , fixWfs :: ![FixWfC] - , globals :: !F.FEnv - , freshIndex :: !Integer - , binds :: !F.BindEnv - , annotMap :: !(AnnInfo Annot) - , tyConInfo :: !(M.HashMap TC.TyCon RTyCon) - , specQuals :: ![F.Qualifier] - , specDecr :: ![(Var, [Int])] - , specLVars :: !(S.HashSet Var) - , specLazy :: !(S.HashSet Var) - , tyConEmbed :: !(F.TCEmb TC.TyCon) - , kuts :: !(F.Kuts) - , lits :: ![(F.Symbol, F.Sort)] - , tcheck :: !Bool - , pruneRefs :: !Bool - , logWarn :: ![String] - } -- deriving (Data, Typeable) - -instance PPrint CGInfo where - pprint cgi = {-# SCC "ppr_CGI" #-} ppr_CGInfo cgi - -ppr_CGInfo cgi - = (text "*********** Haskell SubConstraints ***********") - $$ (pprint $ hsCs cgi) - $$ (text "*********** Haskell WFConstraints ************") - $$ (pprint $ hsWfs cgi) - $$ (text "*********** Fixpoint SubConstraints **********") - $$ (F.toFix $ fixCs cgi) - $$ (text "*********** Fixpoint WFConstraints ************") - $$ (F.toFix $ fixWfs cgi) - $$ (text "*********** Fixpoint Kut Variables ************") - $$ (F.toFix $ kuts cgi) - $$ (text "*********** Literals in Source ************") - $$ (pprint $ lits cgi) - -type CG = State CGInfo - -initCGI cfg info = CGInfo { - hsCs = [] - , hsWfs = [] - , fixCs = [] - , fixWfs = [] - , globals = globs - , freshIndex = 0 - , binds = F.emptyBindEnv - , annotMap = AI M.empty - , tyConInfo = tyi - , specQuals = qualifiers spc - ++ specificationQualifiers (maxParams cfg) (info {spec = spec'}) - , tyConEmbed = tce - , kuts = F.ksEmpty - , lits = coreBindLits tce info - , specDecr = decr spc - , specLVars = lvars spc - , specLazy = lazy spc - , tcheck = not $ notermination cfg - , pruneRefs = not $ noPrune cfg - , logWarn = [] - } - where - tce = tcEmbeds spc - spc = spec info - spec' = spc {tySigs = [ (x, addTyConInfo tce tyi <$> t) | (x, t) <- tySigs spc] } - tyi = makeTyConInfo (tconsP spc) - globs = F.fromListSEnv . map mkSort $ meas spc - mkSort = mapSnd (rTypeSortedReft tce . val) - - -coreBindLits tce info - = sortNub $ [ (x, so) | (_, Just (F.ELit x so)) <- lconsts] - ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons] - where - lconsts = literalConst tce <$> literals (cbs info) - dcons = filter isDCon $ impVars info - dconToSort = typeSort tce . expandTypeSynonyms . varType - dconToSym = dataConSymbol . idDataCon - isDCon x = isDataConWorkId x && not (hasBaseTypeVar x) - -extendEnvWithVV γ t - | F.isNontrivialVV vv - = (γ, "extVV") += (vv, t) - | otherwise - = return γ - where vv = rTypeValueVar t - -{- see tests/pos/polyfun for why you need everything in fixenv -} -(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv -γ ++= (_, x, t') - = do idx <- fresh - let t = normalize γ {-x-} idx t' - let γ' = γ { renv = insertREnv x t (renv γ) } - pflag <- pruneRefs <$> get - is <- if isBase t - then liftM single $ addBind x $ rTypeSortedReft' pflag γ' t - else addClassBind t - return $ γ' { fenv = insertsFEnv (fenv γ) is } - -rTypeSortedReft' pflag γ - | pflag - = pruneUnsortedReft (fe_env $ fenv γ) . f - | otherwise - = f - where f = rTypeSortedReft (emb γ) - -(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv - -(γ, msg) +++= (x, e, t) = (γ{lcb = M.insert x e (lcb γ)}, "+++=") += (x, t) - -(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv -(γ, msg) += (x, r) - | x == F.dummySymbol - = return γ - | x `memberREnv` (renv γ) - = err - | otherwise - = γ ++= (msg, x, r) - where err = errorstar $ msg ++ " Duplicate binding for " - ++ F.symbolString x - ++ "\n New: " ++ showpp r - ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ)) - -γ -= x = γ {renv = deleteREnv x (renv γ), lcb = M.delete x (lcb γ)} - -(??=) :: CGEnv -> F.Symbol -> CG SpecType -γ ??= x - = case M.lookup x (lcb γ) of - Just e -> consE (γ-=x) e - Nothing -> return $ γ ?= x - -(?=) :: CGEnv -> F.Symbol -> SpecType -γ ?= x = fromMaybe err $ lookupREnv x (renv γ) - where err = errorstar $ "EnvLookup: unknown " - ++ showpp x - ++ " in renv " - ++ showpp (renv γ) - -normalize' γ x idx t = traceShow ("normalize " ++ showpp x ++ " idx = " ++ show idx ++ " t = " ++ showpp t) $ normalize γ idx t - -normalize γ idx - = addRTyConInv (invs γ) - . normalizeVV idx - . normalizePds - -normalizeVV idx t@(RApp _ _ _ _) - | not (F.isNontrivialVV (rTypeValueVar t)) - = shiftVV t (F.vv $ Just idx) - -normalizeVV _ t - = t - -shiftVV t@(RApp _ ts _ r) vv' - = t { rt_args = F.subst1 ts (rTypeValueVar t, F.EVar vv') } - { rt_reft = (`F.shiftVV` vv') <$> r } - -shiftVV t _ - = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t - -addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId) -addBind x r - = do st <- get - let (i, bs') = F.insertBindEnv x r (binds st) - put $ st { binds = bs' } - 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 (RCls c ts) --- | isNumericClass c --- = do let numReft = F.trueSortedReft F.FNum --- let numVars = [rTyVarSymbol a | (RVar a _) <- ts] --- is <- forM numVars (`addBind` numReft) --- return is --- addClassBind _ --- = return [] - -addC :: SubC -> String -> CG () -addC !c@(SubC _ t1 t2) _msg - = -- trace ("addC " ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $ - modify $ \s -> s { hsCs = c : (hsCs s) } - -addW :: WfC -> CG () -addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) } - -addWarning :: String -> CG () -addWarning w = modify $ \s -> s { logWarn = w : (logWarn s) } - --- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive definitions. - -addKuts :: SpecType -> CG () -addKuts !t = modify $ \s -> s { kuts = updKuts (kuts s) t } - where - updKuts :: F.Kuts -> SpecType -> F.Kuts - updKuts = foldReft (F.ksUnion . (F.reftKVars . ur_reft) ) - - --- | Used for annotation binders (i.e. at binder sites) - -addIdA :: Var -> Annot -> CG () -addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s } - where - loc = getSrcSpan x - upd m@(AI z) = if boundRecVar loc m then m else addA loc (Just x) t m - -- loc = traceShow ("addIdA: " ++ show x ++ " :: " ++ showpp t ++ " at ") $ getSrcSpan x - -boundRecVar l (AI m) = not $ null [t | (_, RDf t) <- M.lookupDefault [] l m] - - --- | Used for annotating reads (i.e. at Var x sites) - -addLocA :: Maybe Var -> SrcSpan -> Annot -> CG () -addLocA !xo !l !t - = modify $ \s -> s { annotMap = addA l xo t $ annotMap s } - --- | Used to update annotations for a location, due to (ghost) predicate applications - -updateLocA (_:_) (Just l) t = addLocA Nothing l (Use t) -updateLocA _ _ _ = return () - -addA !l !xo@(Just _) !t !(AI m) - | isGoodSrcSpan l - = AI $ inserts l (xo, t) m -addA !l !xo@(Nothing) !t !(AI m) - | l `M.member` m -- only spans known to be variables - = AI $ inserts l (xo, t) m -addA _ _ _ !a - = a - - -------------------------------------------------------------------- ------------------------- Generation: Freshness -------------------- -------------------------------------------------------------------- - --- | Right now, we generate NO new pvars. Rather than clutter code --- with `uRType` calls, put it in one place where the above invariant --- is /obviously/ enforced. - -freshTy :: CoreExpr -> Type -> CG SpecType -freshTy _ = liftM uRType . refresh . ofType - - --- To revert to the old setup, just do --- freshTy_pretty = freshTy --- freshTy_pretty e τ = refresh $ {-traceShow ("exprRefType: " ++ F.showFix e) $-} exprRefType e -freshTy_pretty e _ = do t <- refresh $ {-traceShow ("exprRefType: " ++ F.showFix e) $-} exprRefType e - return $ uRType t - - --- TODO: remove freshRSort? --- freshRSort :: CoreExpr -> RSort -> CG SpecType --- freshRSort e = freshTy e . toType - -trueTy :: Type -> CG SpecType -trueTy t - = do t <- true $ ofType t - tyi <- liftM tyConInfo get - tce <- tyConEmbed <$> get - return $ addTyConInfo tce tyi (uRType t) - -refreshArgs t - = do xs' <- mapM (\_ -> fresh) xs - let su = F.mkSubst $ zip xs (F.EVar <$> xs') - return $ mkArrow αs πs (zip xs' (F.subst su <$> ts)) (F.subst su tbd) - where (αs, πs, t0) = bkUniv t - (xs, ts, tbd) = bkArrow t0 - -instance Freshable CG Integer where - fresh = do s <- get - let n = freshIndex s - put $ s { freshIndex = n + 1 } - return n - -instance TCInfo CG where - getTyConInfo = tyConInfo <$> get - getTyConEmbed = tyConEmbed <$> get - -addTyConInfo tce tyi = mapBot (expandRApp tce tyi) - -------------------------------------------------------------------------------- ------------------------ TERMINATION TYPE --------------------------------------- -------------------------------------------------------------------------------- - -makeDecrIndex :: (Var, SpecType)-> CG [Int] -makeDecrIndex (x, t) - = do hint <- checkHint' . L.lookup x . specDecr <$> get - case dindex of - Nothing -> addWarning msg >> return [] - Just i -> return $ fromMaybe [i] hint - where ts = snd3 $ bkArrow $ thd3 $ bkUniv t - checkHint' = checkHint x ts isDecreasing - dindex = L.findIndex isDecreasing ts - msg = printf "%s: No decreasing parameter" $ showPpr (getSrcSpan x) - -recType ((_, []), (_, [], t)) - = t - -recType ((vs, indexc), (x, index, t)) - = makeRecType t v dxt index - where v = (vs !!) <$> indexc - dxt = (xts !!) <$> index - loc = showPpr (getSrcSpan x) - xts' = bkArrow $ thd3 $ bkUniv t - xts = zip (fst3 xts') (snd3 xts') - msg' = printf "%s: No decreasing argument on %s with %s" - msg = printf "%s: No decreasing parameter" loc - loc (showPpr x) (showPpr vs) - -checkIndex (x, vs, t, index) - = do mapM_ (safeLogIndex msg' vs) index - mapM (safeLogIndex msg ts) index - where loc = showPpr (getSrcSpan x) - ts = snd3 $ bkArrow $ thd3 $ bkUniv t - msg' = printf "%s: No decreasing argument on %s with %s" - msg = printf "%s: No decreasing parameter" loc - loc (showPpr x) (showPpr vs) - --- MOVE THE SAME LENS CHECKS BEFORE - TO DO IT ONCE FOR ALL FUNCTIOS --- makeRecType t vs dxs is | not sameLens --- = errorstar "Constraint.makeRecType: invalid arguments" --- where sameLens = (length vs) == (length is) && (length dxs) == (length is) --- - -makeRecType t vs' dxs' is - = mkArrow αs πs xts' tbd - where xts' = replaceN (last is) (makeDecrType vdxs) xts - vdxs = zip vs dxs - xts = zip xs ts - vs = vs' - dxs = dxs' - (αs, πs, t0) = bkUniv t - (xs, ts, tbd) = bkArrow t0 - -safeLogIndex err ls n - | n >= length ls - = addWarning err >> return Nothing - | otherwise - = return $ Just $ ls !! n - -checkHint _ _ _ Nothing - = Nothing - -checkHint x ts f (Just ns) | L.sort ns /= ns - = errorstar $ printf "%s: The hints should be increasing" loc - where loc = showPpr $ getSrcSpan x - -checkHint x ts f (Just ns) - = Just $ catMaybes (checkValidHint x ts f <$> ns) - -checkValidHint x ts f n - | n < 0 || n >= length ts = errorstar err - | f (ts L.!! n) = Just n - | otherwise = errorstar err - where err = printf "%s: Invalid Hint %d for %s" loc (n+1) (showPpr x) - loc = showPpr $ getSrcSpan x - -------------------------------------------------------------------- --------------------- Generation: Corebind ------------------------- -------------------------------------------------------------------- - -consCBLet γ cb - = do tflag <- tcheck <$> get - consCB tflag γ cb - -consCBTop γ cb - = do oldtcheck <- tcheck <$> get - strict <- specLazy <$> get - let tflag = oldtcheck && (tcond cb strict) - modify $ \s -> s{tcheck = tflag} - γ' <- consCB tflag γ cb - modify $ \s -> s{tcheck = oldtcheck} - return γ' - -tcond cb strict - = not $ any (\x -> S.member x strict || isInternal x) (binds cb) - where binds (NonRec x _) = [x] - binds (Rec xes) = fst $ unzip xes - -------------------------------------------------------------------- -consCB :: Bool -> CGEnv -> CoreBind -> CG CGEnv -------------------------------------------------------------------- - -consCB tflag γ (Rec xes) | tflag - = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) - ts <- mapM refreshArgs $ (fromJust . thd3 <$> xets) - let vs = zipWith collectArgs ts es - is <- checkSameLens <$> mapM makeDecrIndex (zip xs ts) - let xeets = (\vis -> [(vis, x) | x <- zip3 xs is ts]) <$> (zip vs is) - checkEqTypes . L.transpose <$> mapM checkIndex (zip4 xs vs ts is) - let rts = (recType <$>) <$> xeets - let xts = zip xs (Just <$> ts) - γ' <- foldM extender γ xts - let γs = [γ' `withTRec` (zip xs rts') | rts' <- rts] - let xets' = zip3 xs es (Just <$> ts) - mapM_ (uncurry $ consBind True) (zip γs xets') - return γ' - where dmapM f = sequence . (mapM f <$>) - (xs, es) = unzip xes - - - collectArgs = collectArguments . length . fst3 . bkArrow . thd3 . bkUniv - - checkEqTypes = map (checkAll err1 toRSort . catMaybes) - checkSameLens = checkAll err2 length - - err1 = printf "%s: The decreasing parameters should be of same type" loc - err2 = printf "%s: All Recursive functions should have the same number of decreasing parameters" loc - loc = showPpr $ getSrcSpan (head xs) - - checkAll _ _ [] = [] - checkAll err f (x:xs) | all (==(f x)) (f <$> xs) = (x:xs) - | otherwise = errorstar err - --- TODO : no termination check: --- check that the result type is trivial! -consCB _ γ (Rec xes) - = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) - let xts = [(x, to) | (x, _, to) <- xets, not (isGrty x)] - γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts - mapM_ (consBind True γ') xets - return γ' - where isGrty x = (varSymbol x) `memberREnv` (grtys γ) - -consCB _ γ (NonRec x e) - = do to <- varTemplate γ (x, Nothing) - to' <- consBind False γ (x, e, to) - extender γ (x, to') - - -consBind isRec γ (x, e, Just spect) - = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x - γπ <- foldM addPToEnv γ' πs - cconsE γπ e spect - addIdA x (defAnn isRec spect) - return Nothing - where πs = snd3 $ bkUniv spect - -consBind isRec γ (x, e, Nothing) - = do t <- unifyVar γ x <$> consE (γ `setBind` x) e - addIdA x (defAnn isRec t) - return $ Just t - -defAnn True = RDf -defAnn False = Def - -addPToEnv γ π - = do γπ <- γ ++= ("addSpec1", pname π, toPredType π) - foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π] - -extender γ (x, Just t) = γ ++= ("extender", varSymbol x, t) -extender γ _ = return γ - -addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs] - - -varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Maybe SpecType) -varTemplate γ (x, eo) - = case (eo, lookupREnv (varSymbol x) (grtys γ)) of - (_, Just t) -> return $ Just t - (Just e, _) -> do t <- unifyVar γ x <$> freshTy_pretty e (exprType e) - addW (WfC γ t) - addKuts t - return $ Just t - (_, _) -> return Nothing - -unifyVar γ x rt = unify (getPrType γ (varSymbol x)) rt - -------------------------------------------------------------------- --------------------- Generation: Expression ----------------------- -------------------------------------------------------------------- - ------------------------ Type Checking ----------------------------- -cconsE :: CGEnv -> Expr Var -> SpecType -> CG () -------------------------------------------------------------------- -cconsLazyLet γ (Let (NonRec x ex) e) t - = do tx <- {-(`strengthen` xr) <$>-} trueTy (varType x) - γ' <- (γ, "Let NonRec") +++= (x', ex, tx) - cconsE γ' e t - where xr = uTop $ F.symbolReft x' - x' = varSymbol x - -cconsE γ e@(Let b@(NonRec x _) ee) t - = do sp <- specLVars <$> get - if (x `S.member` sp) || isDefLazyVar x' - then cconsLazyLet γ e t - else do γ' <- consCBLet γ b - cconsE γ' ee t - where isDefLazyVar y = "fail" `L.isPrefixOf` y - x' = showPpr x - -cconsE γ (Let b e) t - = do γ' <- consCBLet γ b - cconsE γ' e t - -cconsE γ (Case e x _ cases) t - = do γ' <- consCB False γ $ NonRec x e - forM_ cases $ cconsCase γ' x t nonDefAlts - where nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT] - -cconsE γ (Lam α e) (RAllT α' t) | isTyVar α - = cconsE γ e $ subsTyVar_meet' (α', rVar α) t - -cconsE γ (Lam x e) (RFun y ty t _) - | not (isTyVar x) - = do γ' <- (γ, "cconsE") += (varSymbol x, ty) - cconsE γ' e (t `F.subst1` (y, F.EVar $ varSymbol x)) - addIdA x (Def ty) - -cconsE γ (Tick tt e) t - = cconsE (γ `setLoc` tickSrcSpan tt) e t - -cconsE γ e@(Cast _ _) t - = do t' <- trueTy $ exprType e - addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e) - -cconsE γ e (RAllP p t) - = cconsE γ e t' - where t' = fmap (replacePredsWithRefs su) t - su = (uPVar p, pVartoRConc p) - -cconsE γ e t - = do te <- consE γ e - te' <- instantiatePreds γ e te - addC (SubC γ te' t) ("cconsE" ++ showPpr e) - -instantiatePreds γ e (RAllP p t) - = do s <- freshPredRef γ e p - return $ replacePreds "consE" t [(p, s)] -instantiatePreds _ _ t - = return t - ------------------------ Type Synthesis ---------------------------- -consE :: CGEnv -> Expr Var -> CG SpecType -------------------------------------------------------------------- - -consE γ (Var x) - = do t <- varRefType γ x - addLocA (Just x) (loc γ) (varAnn γ x t) - return t - -consE γ (Lit c) - = return $ uRType $ literalFRefType (emb γ) c - -consE γ (App e (Type τ)) - = do RAllT α te <- liftM (checkAll ("Non-all TyApp with expr", e)) $ consE γ e - t <- if isGeneric α te then freshTy e τ {- =>> addKuts -} else trueTy τ - addW $ WfC γ t - return $ subsTyVar_meet' (α, t) te - -consE γ e'@(App e a) | eqType (exprType a) predType - = do t0 <- consE γ e - case t0 of - RAllP p t -> do s <- freshPredRef γ e' p - return $ replacePreds "consE" t [(p, s)] {- =>> addKuts -} - _ -> return t0 - -consE γ e'@(App e a) - = do ([], πs, te) <- bkUniv <$> consE γ e - zs <- mapM (\π -> liftM ((π,)) $ freshPredRef γ e' π) πs - te' <- return (replacePreds "consE" te zs) {- =>> addKuts -} - (γ', te'') <- dropExists γ te' - updateLocA πs (exprLoc e) te'' - let (RFun x tx t _) = checkFun ("Non-fun App with caller", e') te'' - cconsE γ' a tx - return $ maybe (checkUnbound γ' e' x t) (F.subst1 t . (x,)) (argExpr γ a) --- where err = errorstar $ "consE: App crashes on" ++ showPpr a - - -consE γ (Lam α e) | isTyVar α - = liftM (RAllT (rTyVar α)) (consE γ e) - -consE γ e@(Lam x e1) - = do tx <- freshTy (Var x) τx - γ' <- ((γ, "consE") += (varSymbol x, tx)) - t1 <- consE γ' e1 - addIdA x (Def tx) - addW $ WfC γ tx - return $ rFun (varSymbol x) tx t1 - where FunTy τx _ = exprType e - -consE γ e@(Let _ _) - = cconsFreshE γ e - -consE γ e@(Case _ _ _ _) - = cconsFreshE γ e - -consE γ (Tick tt e) - = do t <- consE (γ `setLoc` l) e - addLocA Nothing l (Use t) - return t - where l = {- traceShow ("tickSrcSpan: e = " ++ showPpr e) $ -} tickSrcSpan tt - - -consE γ e@(Cast _ _) - = trueTy $ exprType e - -consE γ e@(Coercion _) - = trueTy $ exprType e - -consE _ e - = errorstar $ "consE cannot handle " ++ showPpr e - -cconsFreshE γ e - = do t <- freshTy e $ exprType e - addW $ WfC γ t - cconsE γ e t - return t - -checkUnbound γ e x t - | x `notElem` (F.syms t) = t - | otherwise = errorstar $ "consE: cannot handle App " ++ showPpr e ++ " at " ++ showPpr (loc γ) - -dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx) -dropExists γ t = return (γ, t) -------------------------------------------------------------------------------------- -cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG () -------------------------------------------------------------------------------------- - -cconsCase γ x t _ (DataAlt c, ys, ce) - = do xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x' - tdc <- γ ??= (dataConSymbol c) - let (rtd, yts, _) = unfoldR c tdc (shiftVV xt0 x') ys - let r1 = dataConReft c ys' - let r2 = dataConMsReft rtd ys' - let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2)) - let cbs = safeZip "cconsCase" (x':ys') (xt0:yts) - cγ' <- addBinders γ x' cbs - cγ <- addBinders cγ' x' [(x', xt)] - cconsE cγ ce t - where (x':ys') = varSymbol <$> (x:ys) - -cconsCase γ x t acs (a, _, ce) - = do let x' = varSymbol x - xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x') - cγ <- addBinders γ x' [(x', xt')] - cconsE cγ ce t - -altReft γ _ (LitAlt l) = literalFReft (emb γ) l -altReft γ acs DEFAULT = mconcat [notLiteralReft l | LitAlt l <- acs] - where notLiteralReft = maybe F.top F.notExprReft . snd . literalConst (emb γ) -altReft _ _ _ = error "Constraint : altReft" - -unfoldR dc td (RApp _ ts rs _) ys = (t3, tvys ++ yts, rt) - where - tbody = instantiatePvs (instantiateTys td ts) $ reverse rs - (ys0, yts', rt) = safeBkArrow $ instantiateTys tbody tvs' - (t3:yts) = F.subst su <$> (rt:yts') - su = F.mkSubst [(x, F.EVar y) | (x, y)<- zip ys0 ys'] - (αs, ys') = mapSnd (varSymbol <$>) $ L.partition isTyVar ys - tvs' = rVar <$> αs - tvys = ofType . varType <$> αs - -unfoldR _ _ _ _ = error "Constraint.hs : unfoldR" - -instantiateTys = foldl' go - where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody - go _ _ = errorstar "Constraint.instanctiateTy" - -instantiatePvs = foldl' go - where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)] - go _ _ = errorstar "Constraint.instanctiatePv" - -instance Show CoreExpr where - show = showPpr - -checkTyCon _ t@(RApp _ _ _ _) = t -checkTyCon x t = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t - --- checkRPred _ t@(RAll _ _) = t --- checkRPred x t = checkErr x t - -checkFun _ t@(RFun _ _ _ _) = t -checkFun x t = checkErr x t - -checkAll _ t@(RAllT _ _) = t -checkAll x t = checkErr x t - -checkErr (msg, e) t = errorstar $ msg ++ showPpr e ++ "type: " ++ showpp t - -varAnn γ x t - | x `S.member` recs γ - = Loc (getSrcSpan' x) - | otherwise - = Use t - -getSrcSpan' x - | loc == noSrcSpan - = traceShow ("myGetSrcSpan: No Location for: " ++ showPpr x) $ loc - | otherwise - = loc - where loc = getSrcSpan x - ------------------------------------------------------------------------ ----------- Helpers: Creating Fresh Refinement ------------------ ------ ------------------------------------------------------------------------ - -truePredRef :: (PPrint r, F.Reftable r) => PVar (RRType r) -> CG SpecType -truePredRef (PV _ τ _) - = trueTy (toType τ) - -freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG (Ref RSort RReft SpecType) -freshPredRef γ e (PV n τ as) - = do t <- freshTy e (toType τ) - args <- mapM (\_ -> fresh) as - let targs = zip args (fst3 <$> as) - γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs] - addW $ WfC γ' t - return $ RPoly targs t - ------------------------------------------------------------------------ ----------- Helpers: Creating Refinement Types For Various Things ------ ------------------------------------------------------------------------ - -argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr -argExpr _ (Var vy) = Just $ F.EVar $ varSymbol vy -argExpr γ (Lit c) = snd $ literalConst (emb γ) c -argExpr γ (Tick _ e) = argExpr γ e -argExpr _ e = errorstar $ "argExpr: " ++ showPpr e - - -varRefType γ x = liftM (varRefType' γ x) (γ ??= varSymbol x) - -varRefType' γ x t' - | Just tys <- trec γ - = maybe t (`strengthen` xr) (x' `M.lookup` tys) - | otherwise - = t - where t = t' `strengthen` xr - xr = uTop $ F.symbolReft $ varSymbol x - x' = varSymbol x - --- TODO: should only expose/use subt. Not subsTyVar_meet -subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t) - ------------------------------------------------------------------------ ---------------- Forcing Strictness ------------------------------------ ------------------------------------------------------------------------ - -instance NFData CGEnv where - rnf (CGE x1 x2 x3 x4 x5 x6 x7 x8 _ x9 x10 _ _) - = x1 `seq` rnf x2 `seq` seq x3 `seq` x4 `seq` rnf x5 `seq` - rnf x6 `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 - -instance NFData FEnv where - rnf (FE x1 _) = rnf x1 - -instance NFData SubC where - rnf (SubC x1 x2 x3) - = rnf x1 `seq` rnf x2 `seq` rnf x3 - -instance NFData Class where - rnf _ = () - -instance NFData RTyCon where - rnf _ = () - -instance NFData Type where - rnf _ = () - -instance NFData WfC where - rnf (WfC x1 x2) - = rnf x1 `seq` rnf x2 - -instance NFData CGInfo where - rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq` - ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq` - ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq` - ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq` - ({-# SCC "CGIrnf5" #-} rnf (globals x)) `seq` - ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq` - ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq` - ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq` - ({-# SCC "CGIrnf9" #-} rnf (specQuals x)) `seq` - ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq` - ({-# SCC "CGIrnf10" #-} rnf (lits x)) - -------------------------------------------------------------------------------- ---------------------- Reftypes from F.Fixpoint Expressions ---------------------- -------------------------------------------------------------------------------- - -forallExprRefType :: CGEnv -> SpecType -> SpecType -forallExprRefType γ t = t `strengthen` (uTop r') - where r' = maybe F.top (forallExprReft γ) ((F.isSingletonReft) r) - r = F.sr_reft $ rTypeSortedReft (emb γ) t - - -forallExprReft γ (F.EApp f es) = F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t - where (xs,_ , t) = bkArrow $ thd3 $ bkUniv $ forallExprReftLookup γ f - su = F.mkSubst $ safeZip "fExprRefType" xs es - -forallExprReft γ (F.EVar x) = F.sr_reft $ rTypeSortedReft (emb γ) t - where (_,_ , t) = bkArrow $ thd3 $ bkUniv $ forallExprReftLookup γ x - -forallExprReft _ e = F.exprReft e - -forallExprReftLookup γ x = γ ?= x' - where x' = fromMaybe err (varSymbol <$> F.lookupSEnv x γ') - γ' = syenv γ - err = errorstar $ "exReftLookup: unknown " ++ showpp x ++ " in " ++ F.showFix γ' --- withReft (RApp c ts rs _) r' = RApp c ts rs r' --- withReft (RVar a _) r' = RVar a r' --- withReft t _ = t - - -grapBindsWithType tx γ - = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ)) - -splitExistsCases z xs tx - = fmap $ fmap (exrefAddEq z xs tx) - -exrefAddEq z xs t (F.Reft(s, rs)) - = F.Reft(s, [F.RConc (F.POr [ pand x | x <- xs])]) - where tref = fromMaybe F.top $ stripRTypeBase t - pand x = F.PAnd $ (substzx x) (fFromRConc <$> rs) - ++ exrefToPred x tref - substzx x = F.subst (F.mkSubst [(z, F.EVar x)]) - -exrefToPred x uref - = F.subst (F.mkSubst [(v, F.EVar x)]) ((fFromRConc <$> r)) - where (F.Reft(v, r)) = ur_reft uref -fFromRConc (F.RConc p) = p -fFromRConc _ = errorstar "can not hanlde existential type with kvars" - -------------------------------------------------------------------------------- --------------------- Cleaner Signatures For Rec-bindings ---------------------- -------------------------------------------------------------------------------- - -exprLoc :: CoreExpr -> Maybe SrcSpan - -exprLoc (Tick tt _) = Just $ tickSrcSpan tt -exprLoc (App e a) | isType a = exprLoc e -exprLoc _ = Nothing - -isType (Type _) = True -isType a = eqType (exprType a) predType - - -exprRefType :: CoreExpr -> RefType -exprRefType = exprRefType_ M.empty - -exprRefType_ :: M.HashMap Var RefType -> CoreExpr -> RefType -exprRefType_ γ (Let b e) - = exprRefType_ (bindRefType_ γ b) e - -exprRefType_ γ (Lam α e) | isTyVar α - = RAllT (rTyVar α) (exprRefType_ γ e) - -exprRefType_ γ (Lam x e) - = rFun (varSymbol x) (ofType $ varType x) (exprRefType_ γ e) - -exprRefType_ γ (Tick _ e) - = exprRefType_ γ e - -exprRefType_ γ (Var x) - = M.lookupDefault (ofType $ varType x) x γ - -exprRefType_ _ e - = ofType $ exprType e - -bindRefType_ γ (Rec xes) - = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes] - -bindRefType_ γ (NonRec x e) - = extendγ γ [(x, exprRefType_ γ e)] - -extendγ γ xts - = foldr (\(x,t) m -> M.insert x t m) γ xts - -------------------------------------------------------------------- ---------- | Strengthening Binders with TyCon Invariants ----------- -------------------------------------------------------------------- - -type RTyConInv = M.HashMap RTyCon [SpecType] - --- mkRTyConInv :: [Located SpecType] -> RTyConInv -mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts] - where - strip = thd3 . bkUniv . val - -addRTyConInv :: RTyConInv -> SpecType -> SpecType -addRTyConInv m t@(RApp c _ _ _) - = case M.lookup c m of - Nothing -> t - Just ts -> foldl' conjoinInvariant' t ts -addRTyConInv _ t - = t - -conjoinInvariant' t1 t2 - = conjoinInvariantShift t1 t2 - -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) - = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir) - -conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) - = t { rt_reft = r `F.meet` ir } - -conjoinInvariant t@(RVar _ r) (RVar _ ir) - = t { rt_reft = r `F.meet` ir } - -conjoinInvariant t _ - = t - ---------------------------------------------------------------- ------ Refinement Type Environments ---------------------------- ---------------------------------------------------------------- - -newtype REnv = REnv (M.HashMap F.Symbol SpecType) -- deriving (Data, Typeable) - -instance PPrint REnv where - pprint (REnv m) = vcat $ map pprxt $ M.toList m - where - pprxt (x, t) = pprint x <> dcolon <> pprint t - -instance NFData REnv where - rnf (REnv _) = () -- rnf m - -toListREnv (REnv env) = M.toList env -filterREnv f (REnv env) = REnv $ M.filter f env -fromListREnv = REnv . M.fromList -deleteREnv x (REnv env) = REnv (M.delete x env) -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 --- domREnv (REnv env) = M.keys env --- emptyREnv = REnv M.empty - -cgInfoFInfoBot cgi = cgInfoFInfo cgi { specQuals = [] } - -cgInfoFInfoKvars cgi kvars = cgInfoFInfo cgi{fixCs = fixCs' ++ trueCs} - where fixCs' = concatMap (updateCs kvars) (fixCs cgi) - trueCs = (`F.trueSubCKvar` (Ci noSrcSpan Nothing)) <$> kvars - -cgInfoFInfo cgi - = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi - , F.ws = fixWfs cgi - , F.bs = binds cgi - , F.gs = globals cgi - , F.lits = lits cgi - , F.kuts = kuts cgi - , F.quals = specQuals cgi - } - -updateCs kvars cs - | null lhskvars || F.isFalse rhs - = [cs] - | all (`elem` kvars) lhskvars && null lhsconcs - = [] - | any (`elem` kvars) lhskvars - = [F.removeLhsKvars cs kvars] - | otherwise - = [cs] - where lhskvars = F.reftKVars lhs - rhskvars = F.reftKVars rhs - lhs = F.lhsCs cs - rhs = F.rhsCs cs - F.Reft(_, lhspds) = lhs - lhsconcs = [p | F.RConc p <- lhspds] diff --git a/Language/Haskell/Liquid/Desugar/Desugar.lhs b/Language/Haskell/Liquid/Desugar/Desugar.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/Desugar.lhs +++ /dev/null @@ -1,437 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -The Desugarer: turning HsSyn into Core. - -\begin{code} - -{-# LANGUAGE PatternGuards #-} - -{-# OPTIONS -fno-warn-tabs #-} - --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.Desugar ( deSugarWithLoc ) where - -import DynFlags -import StaticFlags -import HscTypes -import HsSyn -import TcRnTypes -import TcRnMonad ( finalSafeMode ) -import MkIface -import Id -import Name -import Type -import InstEnv -import Class -import Avail -import CoreSyn -import CoreSubst -import PprCore -import DsMonad -import Language.Haskell.Liquid.Desugar.DsExpr (dsLExprWithLoc) -import Language.Haskell.Liquid.Desugar.DsBinds -import DsForeign --- import Language.Haskell.Liquid.Desugar.DsExpr () -- Forces DsExpr to be compiled; DsBinds only - -- depends on DsExpr.hi-boot. -import Module -import RdrName -import NameSet -import NameEnv -import Rules -import CoreMonad ( endPass, CoreToDo(..) ) -import ErrUtils -import Outputable -import SrcLoc -import Coverage -import Util -import MonadUtils -import OrdList -import Data.List -import Data.IORef -\end{code} - -%************************************************************************ -%* * -%* The main function: deSugar -%* * -%************************************************************************ - -\begin{code} --- | Main entry point to the desugarer. -deSugarWithLoc :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts) --- Can modify PCS by faulting in more declarations - -deSugarWithLoc 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_tcs = tcs, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) - - = do { let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - ; showPass dflags "Desugar" - -- REACHES THIS ; error "DIE IN DESUGAR" - - -- Desugar the program - ; let export_set = availsToNameSet exports - ; let target = hscTarget dflags - ; let hpcInfo = emptyHpcInfo other_hpc_info - ; (msgs, mb_res) - <- case target of - -- HscNothing -> - -- return (emptyMessages, - -- Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) - _ -> do - - let want_ticks = opt_Hpc - -- || target == HscInterpreted - || (opt_SccProfilingOn - && case profAuto dflags of - NoProfAuto -> False - _ -> True) - - (binds_cvr,ds_hpc_info, modBreaks) - <- if want_ticks && not (isHsBoot hsc_src) - then addTicksToBinds dflags mod mod_loc export_set - (typeEnvTyCons type_env) binds - else return (binds, hpcInfo, emptyModBreaks) - - initDs hsc_env mod rdr_env type_env $ do - 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 - ; let hpc_init - | opt_Hpc = hpcInitCode platform mod ds_hpc_info - | otherwise = empty - ; return ( ds_ev_binds - , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ ds_rules, ds_vects - , ds_fords `appendStubC` hpc_init - , ds_hpc_info, modBreaks) } - - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> 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#! - --- #ifdef DEBUG --- -- Debug only as pre-simple-optimisation program may be really big --- ; endPass dflags CoreDesugar final_pgm rules_for_imps --- #endif - ; (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 - - ; endPass dflags 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 = isHsBoot hsc_src, - 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_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) -\end{code} - -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. - - -\begin{code} -{- deSugarExpr :: HscEnv - -> Module -> GlobalRdrEnv -> TypeEnv - -> LHsExpr Id - -> IO (Messages, Maybe CoreExpr) --- Prints its own errors; returns Nothing if error occurred - -deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do - let dflags = hsc_dflags hsc_env - showPass dflags "Desugar" - - -- Do desugaring - (msgs, mb_core_expr) <- initDs hsc_env this_mod rdr_env type_env $ - dsLExprWithLoc tc_expr - - case mb_core_expr of - Nothing -> return (msgs, Nothing) - Just expr -> do - - -- Dump output - dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr) - - return (msgs, Just expr) --} -\end{code} - -%************************************************************************ -%* * -%* Add rules and export flags to binders -%* * -%************************************************************************ - -\begin{code} -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) -\end{code} - - -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 -%* * -%************************************************************************ - -\begin{code} -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 | RuleBndr (L _ var) <- vars] - - ; lhs' <- unsetDOptM Opt_EnableRewriteRules $ - unsetWOptM Opt_WarnIdentities $ - dsLExprWithLoc lhs -- Note [Desugaring RULE left hand sides] - - ; rhs' <- dsLExprWithLoc 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 becuase - -- 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 - name act fn_name final_bndrs args final_rhs - ; return (Just rule) - } } } -\end{code} - -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 #-} - - -%************************************************************************ -%* * -%* Desugaring vectorisation declarations -%* * -%************************************************************************ - -\begin{code} -dsVect :: LVectDecl Id -> DsM CoreVect -dsVect (L loc (HsVect (L _ v) rhs)) - = putSrcSpanDs loc $ - do { rhs' <- fmapMaybeM dsLExprWithLoc 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) -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsArrows.lhs b/Language/Haskell/Liquid/Desugar/DsArrows.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsArrows.lhs +++ /dev/null @@ -1,1132 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Desugaring arrow commands - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.DsArrows ( dsProcExpr ) where - --- #include "HsVersions.h" - -import Language.Haskell.Liquid.Desugar.Match -import Language.Haskell.Liquid.Desugar.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.Desugar.DsExpr ( dsExpr, dsLExprWithLoc, dsLocalBinds ) - -import TcType -import TcEvidence -import Type -import CoreSyn -import CoreFVs -import CoreUtils -import MkCore - -import Name -import Var -import Id -import DataCon -import TysWiredIn -import BasicTypes -import PrelNames -import Outputable -import Bag -import VarSet -import SrcLoc - -import Data.List -\end{code} - -\begin{code} -data DsCmdEnv = DsCmdEnv { - meth_binds :: [CoreBind], - arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr - } - -mkCmdEnv :: SyntaxTable Id -> DsM DsCmdEnv -mkCmdEnv ids = do - (meth_binds, ds_meths) <- dsSyntaxTable ids - return $ DsCmdEnv { - meth_binds = meth_binds, - arr_id = Var (lookupEvidence ds_meths arrAName), - compose_id = Var (lookupEvidence ds_meths composeAName), - first_id = Var (lookupEvidence ds_meths firstAName), - app_id = Var (lookupEvidence ds_meths appAName), - choice_id = Var (lookupEvidence ds_meths choiceAName), - loop_id = Var (lookupEvidence ds_meths loopAName) - } - -bindCmdEnv :: DsCmdEnv -> CoreExpr -> CoreExpr -bindCmdEnv ids body = foldr Let body (meth_binds ids) - --- 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] - --- map_arrow (f :: b -> c) (g :: a c d) = arr f >>> g :: a b d -do_map_arrow :: DsCmdEnv -> Type -> Type -> Type -> - CoreExpr -> CoreExpr -> CoreExpr -do_map_arrow ids b_ty c_ty d_ty f c - = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c - -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) -> 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))) -\end{code} - -Build case analysis of a tuple. This cannot be done in the DsM monad, -because the list of variables is typically not yet defined. - -\begin{code} --- 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)] -\end{code} - -\begin{code} -mkCorePairTy :: Type -> Type -> Type -mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] - -mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr -mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] -\end{code} - -The input is divided into a local environment, which is a flat tuple -(unless it's too big), and a stack, each element of which is paired -with the environment in turn. 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. - -\begin{code} -envStackType :: [Id] -> [Type] -> Type -envStackType ids stack_tys = foldl mkCorePairTy (mkBigCoreVarTupTy ids) stack_tys - ----------------------------------------------- --- buildEnvStack --- --- (...((x1,...,xn),s1),...sk) - -buildEnvStack :: [Id] -> [Id] -> CoreExpr -buildEnvStack env_ids stack_ids - = foldl mkCorePairExpr (mkBigCoreVarTup env_ids) (map Var stack_ids) - ----------------------------------------------- --- matchEnvStack --- --- \ (...((x1,...,xn),s1),...sk) -> e --- => --- \ zk -> --- case zk of (zk-1,sk) -> --- ... --- case z1 of (z0,s1) -> --- case z0 of (x1,...,xn) -> --- e - -matchEnvStack :: [Id] -- x1..xn - -> [Id] -- s1..sk - -> CoreExpr -- e - -> DsM CoreExpr -matchEnvStack env_ids stack_ids body = do - uniqs <- newUniqueSupply - tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids) - matchVarStack tup_var stack_ids - (coreCaseTuple uniqs tup_var env_ids body) - - ----------------------------------------------- --- matchVarStack --- --- \ (...(z0,s1),...sk) -> e --- => --- \ zk -> --- case zk of (zk-1,sk) -> --- ... --- case z1 of (z0,s1) -> --- e - -matchVarStack :: Id -- z0 - -> [Id] -- s1..sk - -> CoreExpr -- e - -> DsM CoreExpr -matchVarStack env_id [] body - = return (Lam env_id body) -matchVarStack env_id (stack_id:stack_ids) body = do - pair_id <- newSysLocalDs (mkCorePairTy (idType env_id) (idType stack_id)) - matchVarStack pair_id stack_ids - (coreCasePair pair_id env_id stack_id body) -\end{code} - -\begin{code} -mkHsEnvStackExpr :: [Id] -> [Id] -> LHsExpr Id -mkHsEnvStackExpr env_ids stack_ids - = foldl (\a b -> mkLHsTupleExpr [a,b]) - (mkLHsVarTuple env_ids) - (map nlHsVar stack_ids) -\end{code} - -Translation of arrow abstraction - -\begin{code} - --- A | xs |- c :: [] t' ---> c' --- -------------------------- --- A |- proc p -> c :: a t t' ---> arr (\ 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 [] cmd_ty ids)) = do - meth_ids <- mkCmdEnv ids - let locals = mkVarSet (collectPatBinders pat) - (core_cmd, _free_vars, env_ids) <- dsfixCmd meth_ids locals [] cmd_ty cmd - let env_ty = mkBigCoreVarTupTy env_ids - fail_expr <- mkFailExpr ProcExpr env_ty - var <- selectSimpleMatchVarL pat - match_code <- matchSimply (Var var) ProcExpr pat (mkBigCoreVarTup env_ids) fail_expr - let pat_ty = hsLPatType pat - proc_code = do_map_arrow meth_ids pat_ty env_ty cmd_ty - (Lam var match_code) - core_cmd - return (bindCmdEnv meth_ids proc_code) -dsProcExpr _ c = pprPanic "dsProcExpr" (ppr c) -\end{code} - -Translation of command judgements of the form - - A | xs |- c :: [ts] t - -\begin{code} -dsLCmd :: DsCmdEnv -> IdSet -> [Type] -> Type -> LHsCmd Id -> [Id] - -> DsM (CoreExpr, IdSet) -dsLCmd ids local_vars stack res_ty cmd env_ids - = dsCmd ids local_vars stack res_ty (unLoc cmd) env_ids - -dsCmd :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> [Type] -- type of the stack - -> 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 - --- A |- f :: a (t*ts) t' --- A, xs |- arg :: t --- ----------------------------- --- A | xs |- f -< arg :: [ts] t' --- --- ---> arr (\ ((xs)*ts) -> (arg*ts)) >>> f - -dsCmd ids local_vars stack res_ty - (HsArrApp 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 <- dsLExprWithLoc arrow - core_arg <- dsLExprWithLoc arg - stack_ids <- mapM newSysLocalDs stack - core_make_arg <- matchEnvStack env_ids stack_ids - (foldl mkCorePairExpr core_arg (map Var stack_ids)) - return (do_map_arrow ids - (envStackType env_ids stack) - arg_ty - res_ty - core_make_arg - core_arrow, - exprFreeIds core_arg `intersectVarSet` local_vars) - --- A, xs |- f :: a (t*ts) t' --- A, xs |- arg :: t --- ------------------------------ --- A | xs |- f -<< arg :: [ts] t' --- --- ---> arr (\ ((xs)*ts) -> (f,(arg*ts))) >>> app - -dsCmd ids local_vars stack res_ty - (HsArrApp 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 <- dsLExprWithLoc arrow - core_arg <- dsLExprWithLoc arg - stack_ids <- mapM newSysLocalDs stack - core_make_pair <- matchEnvStack env_ids stack_ids - (mkCorePairExpr core_arrow - (foldl mkCorePairExpr core_arg (map Var stack_ids))) - - return (do_map_arrow ids - (envStackType env_ids stack) - (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) - --- A | ys |- c :: [t:ts] t' --- A, xs |- e :: t --- ------------------------ --- A | xs |- c e :: [ts] t' --- --- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c - -dsCmd ids local_vars stack res_ty (HsApp cmd arg) env_ids = do - core_arg <- dsLExprWithLoc arg - let - arg_ty = exprType core_arg - stack' = arg_ty:stack - (core_cmd, free_vars, env_ids') - <- dsfixCmd ids local_vars stack' res_ty cmd - stack_ids <- mapM newSysLocalDs stack - arg_id <- newSysLocalDs arg_ty - -- push the argument expression onto the stack - let - core_body = bindNonRec arg_id core_arg - (buildEnvStack env_ids' (arg_id:stack_ids)) - -- match the environment and stack against the input - core_map <- matchEnvStack env_ids stack_ids core_body - return (do_map_arrow ids - (envStackType env_ids stack) - (envStackType env_ids' stack') - res_ty - core_map - core_cmd, - free_vars `unionVarSet` - (exprFreeIds core_arg `intersectVarSet` local_vars)) - --- A | ys |- c :: [ts] t' --- ----------------------------------------------- --- A | xs |- \ p1 ... pk -> c :: [t1:...:tk:ts] t' --- --- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c - -dsCmd ids local_vars stack res_ty - (HsLam (MatchGroup [L _ (Match pats _ (GRHSs [L _ (GRHS [] body)] _ ))] _)) - env_ids = do - let - pat_vars = mkVarSet (collectPatsBinders pats) - local_vars' = pat_vars `unionVarSet` local_vars - stack' = drop (length pats) stack - (core_body, free_vars, env_ids') <- dsfixCmd ids local_vars' stack' res_ty body - stack_ids <- mapM newSysLocalDs stack - - -- the expression is built from the inside out, so the actions - -- are presented in reverse order - - let - (actual_ids, stack_ids') = splitAt (length pats) stack_ids - -- build a new environment, plus what's left of the stack - core_expr = buildEnvStack env_ids' stack_ids' - in_ty = envStackType env_ids stack - in_ty' = envStackType env_ids' stack' - - fail_expr <- mkFailExpr LambdaExpr in_ty' - -- match the patterns against the top of the old stack - match_code <- matchSimplys (map Var actual_ids) LambdaExpr pats core_expr fail_expr - -- match the old environment and stack against the input - select_code <- matchEnvStack env_ids stack_ids match_code - return (do_map_arrow ids in_ty in_ty' res_ty select_code core_body, - free_vars `minusVarSet` pat_vars) - -dsCmd ids local_vars stack res_ty (HsPar cmd) env_ids - = dsLCmd ids local_vars stack res_ty cmd env_ids - --- A, xs |- e :: Bool --- A | xs1 |- c1 :: [ts] t --- A | xs2 |- c2 :: [ts] t --- ---------------------------------------- --- A | xs |- if e then c1 else c2 :: [ts] t --- --- ---> arr (\ ((xs)*ts) -> --- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> --- c1 ||| c2 - -dsCmd ids local_vars stack res_ty (HsIf mb_fun cond then_cmd else_cmd) - env_ids = do - core_cond <- dsLExprWithLoc cond - (core_then, fvs_then, then_ids) <- dsfixCmd ids local_vars stack res_ty then_cmd - (core_else, fvs_else, else_ids) <- dsfixCmd ids local_vars stack res_ty else_cmd - stack_ids <- mapM newSysLocalDs stack - 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 - then_ty = envStackType then_ids stack - else_ty = envStackType else_ids stack - 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_ids) - core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_ids) - - core_if <- case mb_fun of - Just fun -> do { core_fun <- dsExpr fun - ; matchEnvStack env_ids stack_ids $ - mkCoreApps core_fun [core_cond, core_left, core_right] } - Nothing -> matchEnvStack env_ids stack_ids $ - mkIfThenElse core_cond core_left core_right - - return (do_map_arrow 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) -\end{code} - -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 - - arr (\ ((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 |||. - -\begin{code} -dsCmd ids local_vars stack res_ty (HsCase exp (MatchGroup matches match_ty)) - env_ids = do - stack_ids <- mapM newSysLocalDs stack - - -- 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 res_ty leaf - return ([mkHsEnvStackExpr leaf_ids stack_ids], - envStackType leaf_ids stack, - 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 - - pat_ty = funArgTy match_ty - match_ty' = mkFunTy pat_ty sum_ty - -- Note that we replace the HsCase result type by sum_ty, - -- which is the type of matches' - - core_body <- dsExpr (HsCase exp (MatchGroup matches' match_ty')) - core_matches <- matchEnvStack env_ids stack_ids core_body - return (do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, - exprFreeIds core_body `intersectVarSet` local_vars) - --- A | ys |- c :: [ts] t --- ---------------------------------- --- A | xs |- let binds in c :: [ts] t --- --- ---> arr (\ ((xs)*ts) -> let binds in ((ys)*ts)) >>> c - -dsCmd ids local_vars stack res_ty (HsLet 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 res_ty body - stack_ids <- mapM newSysLocalDs stack - -- build a new environment, plus the stack, using the let bindings - core_binds <- dsLocalBinds binds (buildEnvStack env_ids' stack_ids) - -- match the old environment and stack against the input - core_map <- matchEnvStack env_ids stack_ids core_binds - return (do_map_arrow ids - (envStackType env_ids stack) - (envStackType env_ids' stack) - res_ty - core_map - core_body, - exprFreeIds core_binds `intersectVarSet` local_vars) - -dsCmd ids local_vars [] res_ty (HsDo _ctxt stmts _) env_ids - = dsCmdDo ids local_vars res_ty stmts env_ids - --- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t --- A | xs |- ci :: [tsi] ti --- ----------------------------------- --- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn - -dsCmd _ids local_vars _stack _res_ty (HsArrForm op _ args) env_ids = do - let env_ty = mkBigCoreVarTupTy env_ids - core_op <- dsLExprWithLoc 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 res_ty (HsTick tickish expr) env_ids = do - (expr1,id_set) <- dsLCmd ids local_vars stack res_ty expr env_ids - return (Tick tickish expr1, id_set) - -dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c) - --- A | ys |- c :: [ts] t (ys <= xs) --- --------------------- --- A | xs |- c :: [ts] t ---> arr_ts (\ (xs) -> (ys)) >>> 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 cmd_ty ids)) = do - meth_ids <- mkCmdEnv ids - (core_cmd, free_vars, env_ids') <- dsfixCmd meth_ids local_vars stack cmd_ty cmd - stack_ids <- mapM newSysLocalDs stack - trim_code <- matchEnvStack env_ids stack_ids (buildEnvStack env_ids' stack_ids) - let - in_ty = envStackType env_ids stack - in_ty' = envStackType env_ids' stack - arg_code = if env_ids' == env_ids then core_cmd else - do_map_arrow meth_ids in_ty in_ty' cmd_ty trim_code core_cmd - return (bindCmdEnv meth_ids arg_code, free_vars) - --- Given A | xs |- c :: [ts] t, builds c with xs fed back. --- Typically needs to be prefixed with arr (\p -> ((xs)*ts)) - -dsfixCmd - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this command - -> [Type] -- type of the stack - -> 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 stack cmd_ty cmd - = trimInput (dsLCmd ids local_vars stack 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)) - -\end{code} - -Translation of command judgements of the form - - A | xs |- do { ss } :: [] t - -\begin{code} - -dsCmdDo :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> Type -- return type of the statement - -> [LStmt 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 - --- A | xs |- c :: [] t --- -------------------------- --- A | xs |- do { c } :: [] t - -dsCmdDo _ _ _ [] _ = panic "dsCmdDo" - -dsCmdDo ids local_vars res_ty [L _ (LastStmt body _)] env_ids - = dsLCmd ids local_vars [] res_ty 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) - -\end{code} -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. -\begin{code} -dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> LStmt 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 - -> Stmt 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 - --- A | xs1 |- c :: [] t --- A | xs' |- do { ss } :: [] t' --- ------------------------------ --- A | xs |- do { c; ss } :: [] t' --- --- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> --- arr snd >>> ss - -dsCmdStmt ids local_vars out_ids (ExprStmt cmd _ _ c_ty) env_ids = do - (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd - core_mux <- matchEnvStack env_ids [] - (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) - let - in_ty = mkBigCoreVarTupTy env_ids - in_ty1 = mkBigCoreVarTupTy env_ids1 - 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_map_arrow 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) - where - --- A | xs1 |- c :: [] t --- A | xs' |- do { ss } :: [] t' xs2 = xs' - defs(p) --- ----------------------------------- --- A | xs |- do { p <- c; ss } :: [] t' --- --- ---> arr (\ (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 [] (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 <- matchEnvStack env_ids [] - (mkCorePairExpr (mkBigCoreVarTup env_ids1) (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 = mkBigCoreVarTupTy env_ids1 - in_ty2 = mkBigCoreVarTupTy env_ids2 - before_c_ty = mkCorePairTy in_ty1 in_ty2 - return (do_map_arrow 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)) - --- A | xs' |- do { ss } :: [] t --- -------------------------------------- --- A | xs |- 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 <- matchEnvStack env_ids [] core_binds - return (do_arr ids - (mkBigCoreVarTupTy env_ids) - (mkBigCoreVarTupTy out_ids) - core_map, - exprFreeIds core_binds `intersectVarSet` local_vars) - --- A | ys |- do { ss; returnA -< ((xs1), (ys2)) } :: [] ... --- A | xs' |- do { ss' } :: [] t --- ------------------------------------ --- A | xs |- 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 <- matchEnvStack 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_map_arrow 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 (arr (\ ((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 - -> [LStmt 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 <- matchEnvStack 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 (arr 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_map_arrow 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) - -\end{code} -A sequence of statements (as in a rec) is desugared to an arrow between -two environments -\begin{code} - -dsfixCmdStmts - :: DsCmdEnv -- arrow combinators - -> IdSet -- set of local vars available to this statement - -> [Id] -- output vars of these statements - -> [LStmt 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 - -> [LStmt 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 []" - -\end{code} - -Match a list of expressions against a list of patterns, left-to-right. - -\begin{code} -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" -\end{code} - -List of leaf expressions, with set of variables bound in each - -\begin{code} -leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] -leavesMatch (L _ (Match pats _ (GRHSs grhss binds))) - = let - defined_vars = mkVarSet (collectPatsBinders pats) - `unionVarSet` - mkVarSet (collectLocalBinders binds) - in - [(expr, - mkVarSet (collectLStmtsBinders stmts) - `unionVarSet` defined_vars) - | L _ (GRHS stmts expr) <- grhss] -\end{code} - -Replace the leaf commands in a match - -\begin{code} -replaceLeavesMatch - :: Type -- new result type - -> [LHsExpr Id] -- replacement leaf expressions of that type - -> LMatch Id -- the matches of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LMatch Id) -- updated match -replaceLeavesMatch _res_ty leaves (L loc (Match pat mt (GRHSs grhss binds))) - = let - (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss - in - (leaves', L loc (Match pat mt (GRHSs grhss' binds))) - -replaceLeavesGRHS - :: [LHsExpr Id] -- replacement leaf expressions of that type - -> LGRHS Id -- rhss of a case command - -> ([LHsExpr Id],-- remaining leaf expressions - LGRHS Id) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts _)) - = (leaves, L loc (GRHS stmts leaf)) -replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []" -\end{code} - -Balanced fold of a non-empty list. - -\begin{code} -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 -\end{code} - -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. - -\begin{code} -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@(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] -> [Id] -collectLStmtsBinders = concatMap collectLStmtBinders - -collectLStmtBinders :: LStmt Id -> [Id] -collectLStmtBinders = collectStmtBinders . unLoc - -collectStmtBinders :: Stmt Id -> [Id] -collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat -collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt {}) = [] -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 - -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsBinds.lhs b/Language/Haskell/Liquid/Desugar/DsBinds.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsBinds.lhs +++ /dev/null @@ -1,864 +0,0 @@ -% -% (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). - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, dsTcCoercion - ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr( dsLExprWithLoc ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match( matchWrapper ) - -import DsMonad -import Language.Haskell.Liquid.Desugar.DsGRHSs -import Language.Haskell.Liquid.Desugar.DsUtils -import HsSyn -- lots of things -import CoreSyn -- lots of things -import Literal ( Literal(MachStr) ) -import CoreSubst -import MkCore -import CoreUtils -import CoreArity ( etaExpand ) -import CoreUnfold -import CoreFVs -import UniqSupply -import Unique( Unique ) -import Digraph - - -import TyCon ( isTupleTyCon, tyConDataCons_maybe ) -import TcEvidence -import TcType -import Type -import Coercion hiding (substCo) -import TysWiredIn ( eqBoxDataCon, tupleCon ) -import Id -import Class -import DataCon ( dataConWorkId ) -import Name -import MkId ( seqId ) -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 Util -import Control.Monad( when ) -import MonadUtils -import Control.Monad(liftM) -\end{code} - -%************************************************************************ -%* * -\subsection[dsMonoBinds]{Desugaring a @MonoBinds@} -%* * -%************************************************************************ - -\begin{code} -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 $ dsHsBindWithLoc bind - -dsHsBindWithLoc :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) -dsHsBindWithLoc = dsHsBind - -dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) - -dsHsBind (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless }) - = do { core_expr <- dsLExprWithLoc expr - -- ; _ <- error "DIE REACH HERE dsHsBind 1" - -- 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 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 { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches - -- ; _ <- error "DIE REACH HERE dsHsBind 2" - ; let body' = mkOptTickBox tick body - ; rhs <- dsHsWrapper co_fn (mkLams args body') - ; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -} - return (unitOL (makeCorePair 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 - -- ; _ <- error "DIE REACH HERE dsHsBind 3" - ; 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 { 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 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 { bind_prs <- ds_lhs_binds binds - ; let core_bind = Rec [ makeCorePair (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 - ------------------------- -makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr) -makeCorePair gbl_id is_default_method dict_arity rhs - | is_default_method -- Default methods are *always* inlined - = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, 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 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) - - -dictArity :: [Var] -> Arity --- Don't count coercion variables in arity -dictArity dicts = count isId dicts -\end{code} - -[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, hopefullly 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. - -\begin{code} ------------------------- -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 { let poly_name = idName poly_id - ; spec_name <- newLocalName poly_name - ; (bndrs, ds_lhs) <- liftM collectBinders - (dsHsWrapper spec_co (Var poly_id)) - ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs) - ; case decomposeRuleLhs bndrs ds_lhs of { - Left msg -> do { warnDs msg; return Nothing } ; - Right (final_bndrs, _fn, args) -> do - - { (spec_unf, unf_pairs) <- specUnfolding spec_co spec_ty (realIdUnfolding poly_id) - - ; dflags <- getDynFlags - ; let 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 - final_bndrs args - (mkVarApps (Var spec_id) bndrs) - - ; spec_rhs <- dsHsWrapper spec_co poly_rhs - ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs - - ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) - (warnDs (specOnInline poly_name)) - ; return (Just (spec_pair `consOL` unf_pairs, rule)) - } } } - 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 - - -specUnfolding :: HsWrapper -> Type - -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr)) -{- [Dec 10: TEMPORARILY commented out, until we can straighten out how to - generate unfoldings for specialised DFuns - -specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops) - = do { let spec_rhss = map wrap_fn ops - ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss - ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) } --} -specUnfolding _ _ _ - = return (noUnfolding, nilOL) - -specOnInline :: Name -> MsgDoc -specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") - <+> quotes (ppr f) -\end{code} - - -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} -%* * -%************************************************************************ - -\begin{code} -decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr]) --- Take apart the LHS of a RULE. It's supposed to look like --- /\a. f a Int dOrdInt --- or /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl --- That is, the RULE binders are lambda-bound --- Returns Nothing if the LHS isn't of the expected shape -decomposeRuleLhs bndrs lhs - = -- Note [Simplifying the left-hand side of a RULE] - case collectArgs opt_lhs of - (Var fn, args) -> check_bndrs fn args - - (Case scrut bndr ty [(DEFAULT, _, body)], args) - | isDeadBinder bndr -- Note [Matching seqId] - -> check_bndrs seqId (args' ++ args) - where - args' = [Type (idType bndr), Type ty, scrut, body] - - _other -> Left bad_shape_msg - where - opt_lhs = simpleOptExpr lhs - - check_bndrs fn args - | null (dead_bndrs) = Right (extra_dict_bndrs ++ bndrs, fn, args) - | otherwise = Left (vcat (map dead_msg dead_bndrs)) - where - arg_fvs = exprsFreeVars args - - -- Check for dead binders: Note [Unused spec binders] - dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs - - -- Add extra dict binders: Note [Constant rule dicts] - extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) - | d <- varSetElems (arg_fvs `delVarSetList` bndrs) - , isDictId d] - - - bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) - 2 (ppr opt_lhs) - dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr - , ptext (sLit "is not bound in RULE lhs")]) - 2 (ppr opt_lhs) - 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) -\end{code} - -Note [Simplifying the left-hand side of a RULE] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -simpleOptExpr occurrence-analyses and simplifies the lhs -and thereby -(a) sorts dict bindings into NonRecs and inlines them -(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) does eta reduction - -For (c) 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) - -NB: tcSimplifyRuleLhs is very careful not to generate complicated - dictionary expressions that we might have to match - -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, becuase it mentions a 'd' that is -not bound on the LHS! But it's a silly specialisation anyway, becuase -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 [Constant rule dicts] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -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 -%* * -%************************************************************************ - - -\begin{code} -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 = dsHsWrapper c1 =<< dsHsWrapper c2 e -dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e) -dsHsWrapper (WpEvLam ev) e = return $ Lam ev e -dsHsWrapper (WpTyLam tv) e = return $ Lam tv e -dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm) - --------------------------------------- -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 (EvKindCast v co) - = do { v' <- dsEvTerm v - ; dsTcCoercion co $ (\_ -> v') } - -dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms - ; return (Var df `mkTyApps` tys `mkApps` tms') } -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 = 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 msg) - -dsEvTerm (EvLit l) = - case l of - EvNum n -> mkIntegerExpr n - EvStr s -> mkStringExprFS s - ---------------------------------------- -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#) -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 ty1 ty2 - (ty1, ty2) = getEqPredTys (evVarPred eqv) - - wrap_in_case result_ty (eqv, cov) body - = Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)] - -ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion --- If the incoming TcCoercion if of type (a ~ b), --- the result is of type (a ~# b) --- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b) --- No need for InScope set etc because the -ds_tc_coercion subst tc_co - = go tc_co - where - go (TcRefl ty) = Refl (Coercion.substTy subst ty) - go (TcTyConAppCo tc cos) = mkTyConAppCo 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 tys) = mkAxInstCo ax (map (Coercion.substTy subst) tys) - go (TcSymCo co) = mkSymCo (go co) - go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2) - go (TcNthCo n co) = mkNthCo n (go co) - go (TcInstCo co ty) = mkInstCo (go co) ty - 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 - - 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) -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsExpr.lhs b/Language/Haskell/Liquid/Desugar/DsExpr.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsExpr.lhs +++ /dev/null @@ -1,883 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Desugaring exporessions. - -\begin{code} - -{-# LANGUAGE PatternGuards #-} - -{-# OPTIONS -fno-warn-tabs #-} - -module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExprWithLoc, dsLocalBinds, dsValBinds, dsLit ) where - --- #include "HsVersions.h" - -import Language.Haskell.Liquid.GhcMisc (srcSpanTick) - -import Language.Haskell.Liquid.Desugar.Match -import Language.Haskell.Liquid.Desugar.DsBinds -import Language.Haskell.Liquid.Desugar.DsGRHSs -import Language.Haskell.Liquid.Desugar.DsListComp -import Language.Haskell.Liquid.Desugar.DsUtils -import Language.Haskell.Liquid.Desugar.DsArrows - -import DsMonad -import Language.Haskell.Liquid.Desugar.MatchLit -import Name -import NameEnv - -import HsSyn - --- NB: The desugarer, which straddles the source and Core worlds, sometimes --- needs to see source types -import TcType -import TcEvidence -import TcRnMonad -import Type -import CoreSyn -import CoreUtils -import CoreFVs -import MkCore - -import DynFlags -import StaticFlags -import CostCentre -import Id -import VarSet -import VarEnv -import DataCon -import TysWiredIn -import BasicTypes -import PrelNames -import Maybes -import SrcLoc -import Util -import Bag -import Outputable -import FastString - -import Control.Monad -\end{code} - - -%************************************************************************ -%* * - dsLocalBinds, dsValBinds -%* * -%************************************************************************ - -\begin{code} -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' <- dsLExprWithLoc 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 = binds }) 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 bind -> dsStrictBind (unLoc bind) body) - body1 binds - ; 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 = binds }) - = anyBag (strictMatchOnly . unLoc) binds -strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) - = isUnLiftedType ty - || isBangLPat 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 - -\end{code} - -%************************************************************************ -%* * -\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} -%* * -%************************************************************************ - -\begin{code} --- dsLExpr :: LHsExpr Id -> DsM CoreExpr --- dsLExpr = dsLExprWithLoc - -dsLExprWithLoc :: LHsExpr Id -> DsM CoreExpr - --- dsLExprWithLoc (L loc e) = putSrcSpanDs loc $ dsExpr e -dsLExprWithLoc (L loc e) -- = error "DIED in dsLExprWithLoc" - = do ce <- putSrcSpanDs loc $ dsExpr e - m <- getModuleDs - return $ Tick (srcSpanTick m loc) ce - - -dsExpr :: HsExpr Id -> DsM CoreExpr -dsExpr (HsPar e) = dsLExprWithLoc e -dsExpr (ExprWithTySigOut e _) = dsLExprWithLoc 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' - ; warn_id <- woptM Opt_WarnIdentities - ; when warn_id $ warnAboutIdentities e' wrapped_e - ; return wrapped_e } - -dsExpr (NegApp expr neg_expr) - = App <$> dsExpr neg_expr <*> dsLExprWithLoc expr - -dsExpr (HsLam a_Match) - = uncurry mkLams <$> matchWrapper LambdaExpr a_Match - -dsExpr (HsLamCase arg matches@(MatchGroup _ rhs_ty)) - | isEmptyMatchGroup matches -- A Core 'case' is always non-empty - = -- So desugar empty HsLamCase to error call - mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "\\case")) - | otherwise - = 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 <$> dsLExprWithLoc fun <*> dsLExprWithLoc arg -\end{code} - -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. - -\begin{code} -dsExpr (OpApp e1 op _ e2) - = -- for the type of y, we need the type of op's 2nd argument - mkCoreAppsDs <$> dsLExprWithLoc op <*> mapM dsLExprWithLoc [e1, e2] - -dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = mkCoreAppDs <$> dsLExprWithLoc op <*> dsLExprWithLoc expr - --- dsLExprWithLoc (SectionR op expr) -- \ x -> op x expr -dsExpr (SectionR op expr) = do - core_op <- dsLExprWithLoc 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 <- dsLExprWithLoc 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) (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) (Present expr) - -- Expressions that are present don't generate - -- lambdas, just arguments. - = do { core_expr <- dsLExprWithLoc 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 - mod_name <- getModuleDs - count <- doptM Opt_ProfCountEntries - uniq <- newUnique - Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> dsLExprWithLoc expr - -dsExpr (HsCoreAnn _ expr) - = dsLExprWithLoc expr - -dsExpr (HsCase discrim matches@(MatchGroup _ rhs_ty)) - | isEmptyMatchGroup matches -- A Core 'case' is always non-empty - = -- So desugar empty HsCase to error call - mkErrorAppDs pAT_ERROR_ID (funResultTy rhs_ty) (ptext (sLit "case")) - - | otherwise - = do { core_discrim <- dsLExprWithLoc 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' <- dsLExprWithLoc 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 GhciStmt 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 <- dsLExprWithLoc guard_expr - ; b1 <- dsLExprWithLoc then_expr - ; b2 <- dsLExprWithLoc 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")) -\end{code} - - -\noindent -\underline{\bf Various data construction things} -% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -dsExpr (ExplicitList elt_ty xs) - = dsExplicitList elt_ty 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 dsLExprWithLoc 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 (From from)) - = App <$> dsExpr expr <*> dsLExprWithLoc from - -dsExpr (ArithSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprWithLoc [from, to] - -dsExpr (ArithSeq expr (FromThen from thn)) - = mkApps <$> dsExpr expr <*> mapM dsLExprWithLoc [from, thn] - -dsExpr (ArithSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprWithLoc [from, thn, to] - -dsExpr (PArrSeq expr (FromTo from to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprWithLoc [from, to] - -dsExpr (PArrSeq expr (FromThenTo from thn to)) - = mkApps <$> dsExpr expr <*> mapM dsLExprWithLoc [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 -\end{code} - -\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. - -\begin{code} -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:rhss) -> -- ASSERT( null rhss ) - dsLExprWithLoc rhs - [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl) - unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty 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) -\end{code} - -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. - -\begin{code} -dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) - cons_to_upd in_inst_tys out_inst_tys) - | null fields - = dsLExprWithLoc record_expr - | otherwise - = -- ASSERT2( notNull cons_to_upd, ppr expr ) - - do { record_expr' <- dsLExprWithLoc 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 (MatchGroup alts in_out_ty) - - ; return (add_field_binds field_binds' $ - bindNonRec discrim_var record_expr' matching_code) } - where - ds_field :: HsRecField 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 rec_field = do { rhs <- dsLExprWithLoc (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 - in_out_ty = mkFunTy in_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 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 ty - wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] - - pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs - , pat_dicts = eqs_vars ++ theta_vars - , pat_binds = emptyTcEvBinds - , pat_args = PrefixCon $ map nlVarPat arg_ids - , pat_ty = in_ty } - ; let wrapped_rhs | null eq_spec = rhs - | otherwise = mkLHsWrap (WpCast wrap_co) rhs - ; return (mkSimpleMatch [pat] wrapped_rhs) } - -\end{code} - -Here is where we desugar the Template Haskell brackets and escapes - -\begin{code} --- Template Haskell stuff - --- #ifdef GHCI --- dsExpr (HsBracketOut x ps) = dsBracket x ps --- #else -dsExpr (HsBracketOut _ _) = panic "dsExpr HsBracketOut" --- #endif -dsExpr (HsSpliceE s) = pprPanic "dsExpr:splice" (ppr s) - --- Arrow notation extension -dsExpr (HsProc pat cmd) = dsProcExpr pat cmd -\end{code} - -Hpc Support - -\begin{code} -dsExpr (HsTick tickish e) = do - e' <- dsLExprWithLoc 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 <- dsLExprWithLoc e - do { -- ASSERT(exprType e2 `eqType` boolTy) - mkBinaryTickBox ixT ixF e2 - } -\end{code} - -\begin{code} - --- 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 (HsTickPragma {}) = panic "dsExpr:HsTickPragma" -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 :: [HsRecField Id arg] -> Name -> [arg] -findField rbinds lbl - = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds - , lbl == idName (unLoc id) ] -\end{code} - -%-------------------------------------------------------------------- - -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. - - -\begin{code} -dsExplicitList :: PostTcType -> [LHsExpr Id] -> DsM CoreExpr --- See Note [Desugaring explicit lists] -dsExplicitList elt_ty xs - = do { dflags <- getDynFlags - ; xs' <- mapM dsLExprWithLoc xs - ; let (dynamic_prefix, static_suffix) = spanTail is_static xs' - ; if opt_SimpleListLiterals -- -fsimple-list-literals - || not (dopt 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) } - -spanTail :: (a -> Bool) -> [a] -> ([a], [a]) -spanTail f xs = (reverse rejected, reverse satisfying) - where (satisfying, rejected) = span f $ reverse xs -\end{code} - -Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're -handled in DsListComp). Basically does the translation given in the -Haskell 98 report: - -\begin{code} -dsDo :: [LStmt 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 ) - dsLExprWithLoc body - -- The 'return' op isn't used for 'do' expressions - - go _ (ExprStmt rhs then_expr _ _) stmts - = do { rhs2 <- dsLExprWithLoc 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' <- dsLExprWithLoc 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 - = -- ASSERT( length rec_ids > 0 ) - goL (new_bind_stmt : stmts) - 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 (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - 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) -\end{code} - - -%************************************************************************ -%* * - Warning about identities -%* * -%************************************************************************ - -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 - -\begin{code} -warnAboutIdentities :: CoreExpr -> CoreExpr -> DsM () -warnAboutIdentities (Var v) wrapped_fun - | idName v `elem` conversionNames - , let fun_ty = exprType wrapped_fun - , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty - , arg_ty `eqType` res_ty -- So we are converting ty -> ty - = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty - , nest 2 $ ptext (sLit "can probably be omitted") - , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) - ]) -warnAboutIdentities _ _ = return () - -conversionNames :: [Name] -conversionNames - = [ toIntegerName, toRationalName - , fromIntegralName, realToFracName ] - -- We can't easily add fromIntegerName, fromRationalName, - -- becuase they are generated by literals -\end{code} - -%************************************************************************ -%* * -\subsection{Errors and contexts} -%* * -%************************************************************************ - -\begin{code} --- 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 about discarding non-() things in 'monadic' binding - ; warn_unused <- woptM Opt_WarnUnusedDoBind - ; if warn_unused && not (isUnitTy elt_ty) - then warnDs (unusedMonadBind rhs elt_ty) - 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 - do { warn_wrong <- woptM Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe elt_ty of - Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty - -> warnDs (wrongMonadBind rhs elt_ty) - _ -> return () } } - - | otherwise -- RHS does have type of form (m ty), which is wierd - = return () -- but at lesat this warning is irrelevant - -unusedMonadBind :: LHsExpr Id -> Type -> SDoc -unusedMonadBind rhs elt_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ - ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ - ptext (sLit "or by using the flag -fno-warn-unused-do-bind") - -wrongMonadBind :: LHsExpr Id -> Type -> SDoc -wrongMonadBind rhs elt_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ - ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ - ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot b/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot +++ /dev/null @@ -1,19 +0,0 @@ -\begin{code} - - --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.DsExpr where -import HsSyn ( HsExpr, LHsExpr, HsLocalBinds ) -import Var ( Id ) -import DsMonad ( DsM ) -import CoreSyn ( CoreExpr ) - -dsExpr :: HsExpr Id -> DsM CoreExpr -dsLExprWithLoc :: LHsExpr Id -> DsM CoreExpr -dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs b/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs +++ /dev/null @@ -1,160 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Matching guarded right-hand-sides (GRHSs) - -\begin{code} -module Language.Haskell.Liquid.Desugar.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExprWithLoc, dsLocalBinds ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSinglePat ) - -import HsSyn -import MkCore -import CoreSyn -import Var -import Type - -import DsMonad -import Language.Haskell.Liquid.Desugar.DsUtils -import TysWiredIn -import PrelNames -import Name -import SrcLoc -import Outputable -\end{code} - -@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@. - -\begin{code} -dsGuarded :: GRHSs 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 -\end{code} - -In contrast, @dsGRHSs@ produces a @MatchResult@. - -\begin{code} -dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from - -> GRHSs Id -- Guarded RHSs - -> Type -- Type of RHS - -> DsM MatchResult -dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty = do - match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss - let - match_result1 = foldr1 combineMatchResults match_results - match_result2 = adjustMatchResultDs - (\e -> dsLocalBinds binds e) - match_result1 - -- NB: nested dsLet inside matchResult - -- - return match_result2 - -dsGRHS :: HsMatchContext Name -> Type -> LGRHS Id -> DsM MatchResult -dsGRHS hs_ctx rhs_ty (L _ (GRHS guards rhs)) - = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty -\end{code} - - -%************************************************************************ -%* * -%* matchGuard : make a MatchResult from a guarded RHS * -%* * -%************************************************************************ - -\begin{code} -matchGuards :: [Stmt Id] -- Guard - -> HsStmtContext Name -- Context - -> LHsExpr Id -- RHS - -> Type -- Type of RHS of guard - -> DsM MatchResult - --- See comments with HsExpr.Stmt re what an ExprStmt means --- Here we must be in a guard context (not do-expression, nor list-comp) - -matchGuards [] _ rhs _ - = do { core_rhs <- dsLExprWithLoc rhs - ; return (cantFailMatchResult core_rhs) } - - -- ExprStmts 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 (ExprStmt 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 (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do - match_result <- matchGuards stmts ctx rhs rhs_ty - pred_expr <- dsLExprWithLoc 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 <- dsLExprWithLoc 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 <- getModuleDs - return (Tick (HpcTick this_mod ixT) e)) - -isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e -isTrueLHsExpr _ = Nothing -\end{code} - -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/Language/Haskell/Liquid/Desugar/DsListComp.lhs b/Language/Haskell/Liquid/Desugar/DsListComp.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsListComp.lhs +++ /dev/null @@ -1,879 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Desugaring list comprehensions, monad comprehensions and array comprehensions - -\begin{code} -{-# LANGUAGE NamedFieldPuns #-} - -module Language.Haskell.Liquid.Desugar.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExprWithLoc, dsLocalBinds ) - -import HsSyn -import TcHsSyn -import CoreSyn -import MkCore - -import DsMonad -- the monadery used in the desugarer -import Language.Haskell.Liquid.Desugar.DsUtils - -import DynFlags -import CoreUtils -import Id -import Type -import TysWiredIn -import Language.Haskell.Liquid.Desugar.Match -import PrelNames -import SrcLoc -import Outputable -import FastString -import TcType -import Util -\end{code} - -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. - -\begin{code} -dsListComp :: [LStmt 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 (dopt Opt_EnableRewriteRules dflags) || dopt 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 :: Stmt 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' <- dsLExprWithLoc using - usingArgs <- case by of - Nothing -> return [expr] - Just by_e -> do { by_e' <- dsLExprWithLoc 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" -\end{code} - -%************************************************************************ -%* * -\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. - -\begin{code} - -deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr - -deListComp [] _ = panic "deListComp" - -deListComp (LastStmt body _ : quals) list - = -- Figure 7.4, SLPJ, p 135, rule C above - -- ASSERT( null quals ) - do { core_body <- dsLExprWithLoc body - ; return (mkConsExpr (exprType core_body) core_body list) } - - -- Non-last: must be a guard -deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above - core_guard <- dsLExprWithLoc 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 <- dsLExprWithLoc 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" -\end{code} - - -\begin{code} -deBindComp :: OutPat Id - -> CoreExpr - -> [Stmt 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) -\end{code} - -%************************************************************************ -%* * -\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} - -\begin{code} -dfListComp :: Id -> Id -- 'c' and 'n' - -> [Stmt Id] -- the rest of the qual's - -> DsM CoreExpr - -dfListComp _ _ [] = panic "dfListComp" - -dfListComp c_id n_id (LastStmt body _ : quals) - = -- ASSERT( null quals ) - do { core_body <- dsLExprWithLoc body - ; return (mkApps (Var c_id) [core_body, Var n_id]) } - - -- Non-last: must be a guard -dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do - core_guard <- dsLExprWithLoc 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 <- dsLExprWithLoc 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) - -> [Stmt 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 -\end{code} - -%************************************************************************ -%* * -\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} -%* * -%************************************************************************ - -\begin{code} - -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 -\end{code} - -%************************************************************************ -%* * -\subsection[DsPArrComp]{Desugaring of array comprehensions} -%* * -%************************************************************************ - -\begin{code} - --- entry point for desugaring a parallel array comprehension --- --- [:e | qss:] = <<[:e | qss:]>> () [:():] --- -dsPArrComp :: [Stmt 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 <- dsLExprWithLoc 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 :: [Stmt 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' _ : quals) 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 (ExprStmt 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 <- dsLExprWithLoc 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 --- singeltons 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] -> [Stmt 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 =<< dsLExprWithLoc 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" -\end{code} - -Translation for monad comprehensions - -\begin{code} --- Entry point for monad comprehension desugaring -dsMonadComp :: [LStmt Id] -> DsM CoreExpr -dsMonadComp stmts = dsMcStmts stmts - -dsMcStmts :: [LStmt Id] -> DsM CoreExpr -dsMcStmts [] = panic "dsMcStmts" -dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) - ---------------- -dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr - -dsMcStmt (LastStmt body ret_op) stmts - = -- ASSERT( null stmts ) - do { body' <- dsLExprWithLoc 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' <- dsLExprWithLoc rhs - ; dsMcBindStmt pat rhs' bind_op fail_op stmts } - --- Apply `guard` to the `exp` expression --- --- [ .. | exp, stmts ] --- -dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts - = do { exp' <- dsLExprWithLoc 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' <- dsLExprWithLoc using - ; usingArgs <- case by of - Nothing -> return [expr] - Just by_e -> do { by_e' <- dsLExprWithLoc 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 - -> [LStmt 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 :: [LStmt 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 (elt_tys !! i) - , mk_sel i, Var ys] - - mk_sel n = Lam tup_xs $ - mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs) - - ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/DsUtils.lhs b/Language/Haskell/Liquid/Desugar/DsUtils.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/DsUtils.lhs +++ /dev/null @@ -1,806 +0,0 @@ -% -% (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. - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - --- | Utility functions for constructing Core syntax, principally for desugaring -module Language.Haskell.Liquid.Desugar.DsUtils ( - EquationInfo(..), - firstPat, shiftEqns, - - MatchResult(..), CanItFail(..), - cantFailMatchResult, alwaysFailMatchResult, - extractMatchResult, combineMatchResults, - adjustMatchResult, adjustMatchResultDs, - mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult, - matchCanFail, mkEvalMatchResult, - mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, - wrapBind, wrapBinds, - - mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, - - seqVar, - - -- LHs tuples - mkLHsVarPatTup, mkLHsPatTup, mkVanillaTuplePat, - mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, - - mkSelectorBinds, - - dsSyntaxTable, lookupEvidence, - - selectSimpleMatchVarL, selectMatchVars, selectMatchVar, - mkOptTickBox, mkBinaryTickBox - ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSimply ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr( dsExpr ) - -import HsSyn -import TcHsSyn -import TcType( tcSplitTyConApp ) -import CoreSyn -import DsMonad - -import CoreUtils -import MkCore -import MkId -import Id -import Name -import Literal -import TyCon -import DataCon -import Type -import Coercion -import TysPrim -import TysWiredIn -import BasicTypes -import UniqSet -import UniqSupply -import PrelNames -import Outputable -import SrcLoc -import Util -import ListSetOps -import DynFlags -import FastString - -import Control.Monad ( zipWithM ) -\end{code} - - -%************************************************************************ -%* * - Rebindable syntax -%* * -%************************************************************************ - -\begin{code} -dsSyntaxTable :: SyntaxTable Id - -> DsM ([CoreBind], -- Auxiliary bindings - [(Name,Id)]) -- Maps the standard name to its value - -dsSyntaxTable rebound_ids = do - (binds_s, prs) <- mapAndUnzipM mk_bind rebound_ids - return (concat binds_s, prs) - where - -- The cheapo special case can happen when we - -- make an intermediate HsDo when desugaring a RecStmt - mk_bind (std_name, HsVar id) = return ([], (std_name, id)) - mk_bind (std_name, expr) = do - rhs <- dsExpr expr - id <- newSysLocalDs (exprType rhs) - return ([NonRec id rhs], (std_name, id)) - -lookupEvidence :: [(Name, Id)] -> Name -> Id -lookupEvidence prs std_name - = assocDefault (mk_panic std_name) prs std_name - where - mk_panic std_name = pprPanic "dsSyntaxTable" (ptext (sLit "Not found:") <+> ppr std_name) -\end{code} - -%************************************************************************ -%* * -\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. - -\begin{code} -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... -\end{code} - -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. - -\begin{code} -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 ] -\end{code} - -Functions on MatchResults - -\begin{code} -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) - - -mkCoAlgCaseMatchResult - :: Id -- Scrutinee - -> Type -- Type of exp - -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) - -> MatchResult -mkCoAlgCaseMatchResult var ty match_alts - | isNewTyCon tycon -- 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 -- Sugared parallel array; use a literal case - = MatchResult CanFail mk_parrCase - - | otherwise -- Datatype case; use a case - = MatchResult fail_flag mk_case - where - tycon = dataConTyCon con1 - -- [Interesting: becuase of GADTs, we can't rely on the type of - -- the scrutinised Id to be sufficiently refined to have a TyCon in it] - - -- Stuff for newtype - (con1, arg_ids1, match_result1) = {- ASSERT( notNull match_alts ) -} head match_alts - 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 data types - data_cons = tyConDataCons tycon - match_results = [match_result | (_,_,match_result) <- match_alts] - - fail_flag | exhaustive_case - = foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results] - | otherwise - = CanFail - - sorted_alts = sortWith get_tag match_alts - get_tag (con, _, _) = dataConTag con - mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts - return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)) - - mk_alt fail (con, args, MatchResult _ body_fn) = do - body <- body_fn fail - us <- newUniqueSupply - return (mkReboxingAlt (uniqsFromSupply us) con args body) - - mk_default fail | exhaustive_case = [] - | otherwise = [(DEFAULT, [], fail)] - - un_mentioned_constructors - = mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- match_alts] - 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 - -- - -- 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 [(dcon, _, _)] = isPArrFakeCon dcon - isPArrFakeAlts ((dcon, _, _):alts) = - case (isPArrFakeCon dcon, 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" - -- - mk_parrCase 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 (con, args, MatchResult _ bodyFun) = do - body <- bodyFun fail - return (LitAlt lit, [], mkCoreLets binds body) - where - lit = MachInt $ toInteger (dataConSourceArity con) - binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] - -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i] -\end{code} - -%************************************************************************ -%* * -\subsection{Desugarer's versions of some Core functions} -%* * -%************************************************************************ - -\begin{code} -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]) -\end{code} - -'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'. - -\begin{code} -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 -\end{code} - - -%************************************************************************ -%* * -\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 - -\begin{code} -mkSelectorBinds :: [Maybe (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 use coerce for that - ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat) - ; err_var <- newSysLocalDs unitTy - ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders - ; return ( (val_var, val_expr) : - (err_var, err_expr) : - 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 Nothing - - 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 -> coerce (type-of-bv) err_var } - -- 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 = mkCast (Var err_var) co - co = mkUnsafeCo (exprType (Var err_var)) (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{}) = isProductTyCon (dataConTyCon (unLoc (pat_con pat))) - && all is_triv_lpat (hsConPatArgs (pat_args pat)) - 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 -\end{code} - -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. - -\begin{code} -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 (mkTupleTy (boxityNormalTupleSort 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 -\end{code} - -%************************************************************************ -%* * -\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. - -\begin{code} -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 (realWorldStatePrimTy `mkFunTy` ty) - ; fail_fun_arg <- newSysLocalDs realWorldStatePrimTy - ; return (NonRec fail_fun_var (Lam fail_fun_arg expr), - App (Var fail_fun_var) (Var realWorldPrimId)) } - where - ty = exprType expr -\end{code} - -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. - -\begin{code} -mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr -mkOptTickBox Nothing e = e -mkOptTickBox (Just tickish) e = Tick tickish e - -mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr -mkBinaryTickBox ixT ixF e = do - uq <- newUnique - this_mod <- getModuleDs - 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) - ] -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/HscMain.hs b/Language/Haskell/Liquid/Desugar/HscMain.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/HscMain.hs +++ /dev/null @@ -1,55 +0,0 @@ -module Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) where - -import GHC (ModLocation, ParsedMod, TypecheckedMod) -import TcRnTypes -import HscTypes -import MonadUtils -import ErrUtils -import Bag -import CoreMonad hiding (getHscEnv) -import Language.Haskell.Liquid.Desugar.Desugar (deSugarWithLoc) -import Exception - -newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) - -instance Monad Hsc where - return a = Hsc $ \_ w -> return (a, w) - Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w - case k a of - Hsc k' -> k' e w1 - -instance MonadIO Hsc where - liftIO io = Hsc $ \_ w -> do { a <- io; return (a, w) } - -hscDesugarWithLoc :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts -hscDesugarWithLoc hsc_env mod_summary tc_result = - runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result - -runHsc :: HscEnv -> Hsc a -> IO a -runHsc hsc_env (Hsc hsc) = do - (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_dflags hsc_env) w - return a - -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 - return r - -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 -> {- ASSERT( isEmptyBag errs ) -} return r - -logWarnings :: WarningMessages -> Hsc () -logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) - -throwErrors :: ErrorMessages -> Hsc a -throwErrors = liftIO . throwIO . mkSrcErr - -getHscEnv :: Hsc HscEnv -getHscEnv = Hsc $ \e w -> return (e, w) diff --git a/Language/Haskell/Liquid/Desugar/Match.lhs b/Language/Haskell/Liquid/Desugar/Match.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/Match.lhs +++ /dev/null @@ -1,982 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -The @match@ function - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where - --- #include "HsVersions.h" - -import {-#SOURCE#-} Language.Haskell.Liquid.Desugar.DsExpr (dsLExprWithLoc) - -import DynFlags -import HsSyn -import TcHsSyn -import TcEvidence -import Check -import CoreSyn -import Literal -import CoreUtils -import MkCore -import DsMonad -import Language.Haskell.Liquid.Desugar.DsBinds -import Language.Haskell.Liquid.Desugar.DsGRHSs -import Language.Haskell.Liquid.Desugar.DsUtils -import Id -import DataCon -import Language.Haskell.Liquid.Desugar.MatchCon -import Language.Haskell.Liquid.Desugar.MatchLit -import Type -import TysWiredIn -import ListSetOps -import SrcLoc -import Maybes -import Util -import Name -import Outputable -import BasicTypes ( boxityNormalTupleSort ) -import FastString - -import Control.Monad( when ) -import qualified Data.Map as Map -\end{code} - -This function is a wrapper of @match@, it must be called from all the parts where -it was called match, but only substitutes the firs 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 - -\begin{code} -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 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 -\end{code} - -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?) - -\begin{code} -maximum_output :: Int -maximum_output = 4 -\end{code} - -The next two functions create the warning message. - -\begin{code} -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)) -\end{code} - - -%************************************************************************ -%* * - 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@. - -\begin{code} -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 ) - do { -- _ <- error "DIE in match 1" ; - return (foldr1 combineMatchResults match_results) } - where - match_results = [ -- ASSERT( null (eqn_pats eqn) ) - eqn_rhs eqn - | eqn <- eqns ] - -match vars@(v:_) ty eqns - = -- ASSERT( not (null eqns ) ) - do { -- Tidy the first pattern, generating - -- auxiliary bindings if necessary - -- _ <- error "DIE in match 1" ; - (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns - - -- Group the equations and match each group in turn - ; let grouped = groupEquations tidy_eqns - - -- print the view patterns that are commoned up to help debug - ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) - - ; match_results <- mapM match_group grouped - ; return (adjustMatchResult (foldr1 (.) aux_binds) $ - foldr1 combineMatchResults match_results) } - where - dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo] - dropGroup = map snd - - 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]) - 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) - - -- 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 lits - 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)) - -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' <- dsLExprWithLoc viewExpr - ; return (mkViewMatchResult var' viewExpr' var match_result) } -matchView _ _ _ = panic "matchView" - --- 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 :: 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 "getBangPat" -\end{code} - -%************************************************************************ -%* * - 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} - -\begin{code} -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) - - -- 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) - = return (idDsWrapper, unLoc list_ConPat) - where - list_ty = mkListTy ty - list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) - (mkNilPat list_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 (mkPArrTy ty) - -tidy1 _ (TuplePat pats boxity ty) - = return (idDsWrapper, unLoc tuple_ConPat) - where - arity = length pats - tuple_ConPat = mkPrefixConPat (tupleCon (boxityNormalTupleSort boxity) arity) pats ty - --- 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 lit mb_neg eq) - = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) - --- BangPatterns: Pattern matching is already strict in constructors, --- tuples etc, so the last case strips off the bang for thoses patterns. -tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p) -tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p) -tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _ (SigPatOut _ _))) = return (idDsWrapper, p) -tidy1 v (BangPat (L _ (AsPat (L _ var) pat))) - = do { (wrap, pat') <- tidy1 v (BangPat pat) - ; return (wrapBind var v . wrap, pat') } -tidy1 v (BangPat (L _ p)) = tidy1 v p - --- Everything else goes through unchanged... - -tidy1 _ non_interesting_pat - = return (idDsWrapper, non_interesting_pat) -\end{code} - -\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} - -\begin{code} -matchWrapper :: HsMatchContext Name -- For shadowing warning messages - -> MatchGroup Id -- Matches being desugared - -> DsM ([Id], CoreExpr) -- Results -\end{code} - - 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 - -\begin{code} -matchWrapper ctxt (MatchGroup matches match_ty) - = -- ASSERT( notNull matches ) - do { eqns_info <- mapM mk_eqn_info matches - ; new_vars <- selectMatchVars arg_pats - ; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty - ; return (new_vars, result_expr) } - where - arg_pats = map unLoc (hsLMatchPats (head matches)) - n_pats = length arg_pats - (_, rhs_ty) = splitFunTysN n_pats match_ty - - 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}) } - - -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 } -\end{code} - -%************************************************************************ -%* * -\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. - -\begin{code} -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') } -\end{code} - - -%************************************************************************ -%* * - Pattern classification -%* * -%************************************************************************ - -\begin{code} -data PatGroup - = PgAny -- Immediate match: variables, wildcards, - -- lazy patterns - | PgCon DataCon -- Constructor patterns (incl list, tuple) - | 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) - -groupEquations :: [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 eqns - = runs same_gp [(patGroup (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 -\end{code} - -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! - - -\begin{code} -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 (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 gorup 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 (Present e1) (Present e2) = lexp e1 e2 - tup_arg (Missing t1) (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 (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 - eq_co (TcRefl t1) (TcRefl t2) = eqType t1 t2 - eq_co (TcCoVarCo v1) (TcCoVarCo v2) = v1==v2 - eq_co (TcSymCo co1) (TcSymCo co2) = co1 `eq_co` co2 - eq_co (TcTyConAppCo tc1 cos1) (TcTyConAppCo tc2 cos2) = tc1==tc2 && eq_list eq_co cos1 cos2 - eq_co _ _ = False - -patGroup :: Pat Id -> PatGroup -patGroup (WildPat {}) = PgAny -patGroup (BangPat {}) = PgBang -patGroup (ConPatOut { pat_con = dc }) = PgCon (unLoc dc) -patGroup (LitPat lit) = PgLit (hsLitKey lit) -patGroup (NPat olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) -patGroup (NPlusKPat _ 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 pat = pprPanic "patGroup" (ppr pat) -\end{code} - -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/Language/Haskell/Liquid/Desugar/Match.lhs-boot b/Language/Haskell/Liquid/Desugar/Match.lhs-boot deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/Match.lhs-boot +++ /dev/null @@ -1,42 +0,0 @@ -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.Match where -import Var ( Id ) -import TcType ( Type ) -import DsMonad ( DsM, EquationInfo, MatchResult ) -import CoreSyn ( CoreExpr ) -import HsSyn ( LPat, HsMatchContext, MatchGroup ) -import Name ( Name ) - -match :: [Id] - -> Type - -> [EquationInfo] - -> DsM MatchResult - -matchWrapper - :: HsMatchContext Name - -> MatchGroup Id - -> DsM ([Id], CoreExpr) - -matchSimply - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> CoreExpr - -> CoreExpr - -> DsM CoreExpr - -matchSinglePat - :: CoreExpr - -> HsMatchContext Name - -> LPat Id - -> Type - -> MatchResult - -> DsM MatchResult -\end{code} diff --git a/Language/Haskell/Liquid/Desugar/MatchCon.lhs b/Language/Haskell/Liquid/Desugar/MatchCon.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/MatchCon.lhs +++ /dev/null @@ -1,262 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Pattern-matching constructors - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.MatchCon ( matchConFamily ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( match ) - -import HsSyn -import Language.Haskell.Liquid.Desugar.DsBinds -import DataCon -import TcType -import DsMonad -import Language.Haskell.Liquid.Desugar.DsUtils -import MkCore ( mkCoreLets ) -import Util -import ListSetOps ( runs ) -import Id -import NameEnv -import SrcLoc -import Outputable -import Control.Monad(liftM) -\end{code} - -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. -\begin{code} -matchConFamily :: [Id] - -> Type - -> [[EquationInfo]] - -> DsM MatchResult --- Each group of eqns is for a single constructor -matchConFamily (var:vars) ty groups - = do { alts <- mapM (matchOneCon vars ty) groups - ; return (mkCoAlgCaseMatchResult var ty alts) } -matchConFamily [] _ _ = panic "matchConFamily []" - -type ConArgPats = HsConDetails (LPat Id) (HsRecFields Id (LPat Id)) - -matchOneCon :: [Id] - -> Type - -> [EquationInfo] - -> DsM (DataCon, [Var], MatchResult) -matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { arg_vars <- selectConMatchVars 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 (con1, tvs1 ++ dicts1 ++ arg_vars, - foldr1 combineMatchResults match_results) } - where - ConPatOut { pat_con = L _ con1, pat_ty = pat_ty1, - pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 } - = firstPat eqn1 - fields1 = dataConFieldLabels con1 - - arg_tys = dataConInstOrigArgTys con1 inst_tys - inst_tys = tcTyConAppArgs pat_ty1 ++ - mkTyVarTys (takeList (dataConExTyVars con1) tvs1) - -- Newtypes opaque, hence tcTyConAppArgs - -- dataConInstOrigArgTys takes the univ and existential tyvars - -- and returns the types of the *value* args, which is what we want - - match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult - -- All members of the group have compatible ConArgPats - match_group arg_vars 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 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 rpat = lookupNameEnv_NF fld_var_env - (idName (unLoc (hsRecFieldId rpat))) - select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []" -matchOneCon _ _ [] = 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 (\f1 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) rpats -\end{code} - -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/Language/Haskell/Liquid/Desugar/MatchLit.lhs b/Language/Haskell/Liquid/Desugar/MatchLit.lhs deleted file mode 100644 --- a/Language/Haskell/Liquid/Desugar/MatchLit.lhs +++ /dev/null @@ -1,328 +0,0 @@ -% -% (c) The University of Glasgow 2006 -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% - -Pattern-matching literal patterns - -\begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module Language.Haskell.Liquid.Desugar.MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey, - tidyLitPat, tidyNPat, - matchLiterals, matchNPlusKPats, matchNPats ) where - --- #include "HsVersions.h" - -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( match ) -import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr ) - -import DsMonad -import Language.Haskell.Liquid.Desugar.DsUtils - -import HsSyn - -import Id -import CoreSyn -import MkCore -import TyCon -import DataCon -import TcHsSyn ( shortCutLit ) -import TcType -import PrelNames -import TysWiredIn -import Literal -import SrcLoc -import Data.Ratio -import Outputable -import BasicTypes -import Util -import FastString -\end{code} - -%************************************************************************ -%* * - 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. - -\begin{code} -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) = return (mkIntExpr 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 --- Post-typechecker, the SyntaxExpr field of an OverLit contains --- (an expression for) the literal value itself -dsOverLit (OverLit { ol_val = val, ol_rebindable = rebindable - , ol_witness = witness, ol_type = ty }) - | not rebindable - , Just expr <- shortCutLit val ty = dsExpr expr -- Note [Literal short cut] - | otherwise = dsExpr witness -\end{code} - -Note [Literal short cut] -~~~~~~~~~~~~~~~~~~~~~~~~ -The type checker tries to do this short-cutting as early as possible, but -becuase 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 do do so. - - -\begin{code} -hsLitKey :: 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 (HsIntPrim i) = mkMachInt i -hsLitKey (HsWordPrim w) = mkMachWord 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 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 s -\end{code} - -%************************************************************************ -%* * - Tidying lit pats -%* * -%************************************************************************ - -\begin{code} -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 c) = unLoc (mkCharLitPat c) -tidyLitPat (HsString s) - | lengthFS s <= 1 -- Short string literals only - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) - (mkNilPat stringTy) (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 wierd 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] ty) - - 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 over_lit mb_neg eq -\end{code} - - -%************************************************************************ -%* * - Pattern matching on LitPat -%* * -%************************************************************************ - -\begin{code} -matchLiterals :: [Id] - -> Type -- Type of the whole case expression - -> [[EquationInfo]] -- All PgLits - -> DsM MatchResult - -matchLiterals (var:vars) ty sub_groups - = -- ASSERT( 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 { let LitPat hs_lit = firstPat (head eqns) - ; match_result <- match vars ty (shiftEqns eqns) - ; return (hsLitKey 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 { 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 []" -\end{code} - - -%************************************************************************ -%* * - Pattern matching on NPat -%* * -%************************************************************************ - -\begin{code} -matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult -matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal - = do { let NPat 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)) -\end{code} - - -%************************************************************************ -%* * - 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} - - -\begin{code} -matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult --- All NPlusKPats, for the *same* literal k -matchNPlusKPats (var:vars) ty (eqn1:eqns) - = do { let NPlusKPat (L _ n1) 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)) -\end{code} diff --git a/Language/Haskell/Liquid/DiffCheck.hs b/Language/Haskell/Liquid/DiffCheck.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/DiffCheck.hs +++ /dev/null @@ -1,213 +0,0 @@ --- | This module contains the code for Incremental checking, which finds the --- part of a target file (the subset of the @[CoreBind]@ that have been --- modified since it was last checked (as determined by a diff against --- a saved version of the file. - -module Language.Haskell.Liquid.DiffCheck (slice, save, thin) where - -import Control.Applicative ((<$>)) -import Data.Algorithm.Diff -import CoreSyn -import Name -import SrcLoc --- import Outputable -import Var -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as M -import qualified Data.List as L -import Data.Function (on) -import System.Directory (copyFile, doesFileExist) - -import Language.Fixpoint.Files -import Language.Haskell.Liquid.GhcInterface -import Language.Haskell.Liquid.GhcMisc -import Text.Parsec.Pos (sourceLine) -import Control.Monad(forM) - - -------------------------------------------------------------------------- --- Data Types ----------------------------------------------------------- -------------------------------------------------------------------------- - -data Def = D { start :: Int - , end :: Int - , binder :: Var - } - deriving (Eq, Ord) - -instance Show Def where - show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j - - - --- | `slice` returns a subset of the @[CoreBind]@ of the input `target` --- file which correspond to top-level binders whose code has changed --- and their transitive dependencies. -------------------------------------------------------------------------- -slice :: FilePath -> [CoreBind] -> IO [CoreBind] -------------------------------------------------------------------------- -slice target cbs - = do let saved = extFileName Saved target - ex <- doesFileExist saved - if ex then do is <- {- tracePpr "INCCHECK: changed lines" <$> -} lineDiff target saved - let dfs = coreDefs cbs - forM dfs $ putStrLn . ("INCCHECK: Def " ++) . show - let xs = diffVars is dfs - return $ thin cbs xs - else return cbs - --- | `thin` returns a subset of the @[CoreBind]@ given which correspond --- to those binders that depend on any of the @Var@s provided. -------------------------------------------------------------------------- -thin :: [CoreBind] -> [Var] -> [CoreBind] -------------------------------------------------------------------------- -thin cbs xs = filterBinds cbs ys - where - ys = dependentVars (coreDeps cbs) $ S.fromList xs - -------------------------------------------------------------------------- -filterBinds :: [CoreBind] -> S.HashSet Var -> [CoreBind] -------------------------------------------------------------------------- -filterBinds cbs ys = filter f cbs - where - f (NonRec x _) = x `S.member` ys - f (Rec xes) = any (`S.member` ys) $ fst <$> xes - -------------------------------------------------------------------------- -coreDefs :: [CoreBind] -> [Def] -------------------------------------------------------------------------- -coreDefs cbs = L.sort [D l l' x | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b] -coreDef b = meetSpans b eSp vSp - where - eSp = lineSpan b $ catSpans b $ bindSpans b - vSp = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b - --- | `meetSpans` cuts off the start-line to be no less than the line at which --- the binder is defined. Without this, i.e. if we ONLY use the ticks and --- spans appearing inside the definition of the binder (i.e. just `eSp`) --- then the generated span can be WAY before the actual definition binder, --- possibly due to GHC INLINE pragmas or dictionaries OR ... --- for an example: see the "INCCHECK: Def" generated by --- liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs --- where `spanEnd` is a single line function around 1092 but where --- the generated span starts mysteriously at 222 where Data.List is imported. - -meetSpans b Nothing _ - = error $ "INCCHECK: cannot find span for top-level binders: " - ++ showPpr (bindersOf b) - ++ "\nRun without --diffcheck option\n" - -meetSpans b (Just (l,l')) Nothing - = (l, l') -meetSpans b (Just (l,l')) (Just (m,_)) - = (max l m, l') - --- coreDef b = lineSpan $ catSpans b $ map getSrcSpan --- $ tracePpr ("INCCHECK: letvars " ++ showPpr (bindersOf b)) --- $ letVars b - -lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp) -lineSpan b _ = Nothing -- error $ "INCCHECK: lineSpan unexpected dummy span in lineSpan" ++ showPpr (bindersOf b) - -catSpans b [] = error $ "INCCHECK: catSpans: no spans found for " ++ showPpr b -catSpans b xs = foldr1 combineSrcSpans xs - -bindSpans (NonRec x e) = getSrcSpan x : exprSpans e -bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es - where - (xs, es) = unzip xes -exprSpans (Tick t _) = [tickSrcSpan t] -exprSpans (Var x) = [getSrcSpan x] -exprSpans (Lam x e) = getSrcSpan x : exprSpans e -exprSpans (App e a) = exprSpans e ++ exprSpans a -exprSpans (Let b e) = bindSpans b ++ exprSpans e -exprSpans (Cast e _) = exprSpans e -exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs -exprSpans e = [] - -altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e - - --- coreDefs cbs = mkDefs lxs --- where --- lxs = coreDefs' cbs --- -- lxs = L.sortBy (compare `on` fst) [(line x, x) | x <- xs ] --- -- xs = concatMap bindersOf cbs --- -- line = sourceLine . getSourcePos --- --- mkDefs [] = [] --- mkDefs ((l,x):lxs) = case lxs of --- [] -> [D l Nothing x] --- (l',_):_ -> (D l (Just l') x) : mkDefs lxs --- --- coreDefs' cbs = L.sort [(l, x) | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b] - - -------------------------------------------------------------------------- -coreDeps :: [CoreBind] -> Deps -------------------------------------------------------------------------- -coreDeps = M.fromList . concatMap bindDep - -bindDep b = [(x, ys) | x <- bindersOf b] - where - ys = S.fromList $ freeVars S.empty b - -type Deps = M.HashMap Var (S.HashSet Var) - -------------------------------------------------------------------------- -dependentVars :: Deps -> S.HashSet Var -> S.HashSet Var -------------------------------------------------------------------------- -dependentVars d xs = {- tracePpr "INCCHECK: tx changed vars" $ -} - go S.empty $ {- tracePpr "INCCHECK: seed changed vars" -} xs - where - pre = S.unions . fmap deps . S.toList - deps x = M.lookupDefault S.empty x d - go seen new - | S.null new = seen - | otherwise = let seen' = S.union seen new - new' = pre new `S.difference` seen' - in go seen' new' - -------------------------------------------------------------------------- -diffVars :: [Int] -> [Def] -> [Var] -------------------------------------------------------------------------- -diffVars lines defs = -- tracePpr ("INCCHECK: diffVars lines = " ++ show lines ++ " defs= " ++ show defs) $ - go (L.sort lines) (L.sort defs) - where - go _ [] = [] - go [] _ = [] - go (i:is) (d:ds) - | i < start d = go is (d:ds) - | i > end d = go (i:is) ds - | otherwise = binder d : go (i:is) ds - -------------------------------------------------------------------------- --- Diff Interface ------------------------------------------------------- -------------------------------------------------------------------------- - --- | `save` creates an .saved version of the `target` file, which will be --- used to find what has changed the /next time/ `target` is checked. -------------------------------------------------------------------------- -save :: FilePath -> IO () -------------------------------------------------------------------------- -save target = copyFile target $ extFileName Saved target - - --- | `lineDiff src dst` compares the contents of `src` with `dst` --- and returns the lines of `src` that are different. -------------------------------------------------------------------------- -lineDiff :: FilePath -> FilePath -> IO [Int] -------------------------------------------------------------------------- -lineDiff src dst - = do s1 <- getLines src - s2 <- getLines dst - let ns = diffLines 1 $ getGroupedDiff s1 s2 - putStrLn $ "INCCHECK: diff lines = " ++ show ns - return ns - -diffLines _ [] = [] -diffLines n (Both ls _ : d) = diffLines n' d where n' = n + length ls -diffLines n (First ls : d) = [n .. (n' - 1)] ++ diffLines n' d where n' = n + length ls -diffLines n (Second _ : d) = diffLines n d - -getLines = fmap lines . readFile diff --git a/Language/Haskell/Liquid/Fresh.hs b/Language/Haskell/Liquid/Fresh.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Fresh.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Language.Haskell.Liquid.Fresh ( - Freshable(..), TCInfo(..) - ) where - -import Control.Monad.State -import Control.Applicative ((<$>)) - -import qualified TyCon as TC - -import qualified Data.HashMap.Strict as M - -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType (uTop, expandRApp) -import Language.Fixpoint.Types -import Language.Fixpoint.Misc - -type TTCInfo = M.HashMap TC.TyCon RTyCon -type TTCEmbed = TCEmb TC.TyCon - -class Monad m => Freshable m a where - fresh :: m a - true :: a -> m a - true = return . id - refresh :: a -> m a - refresh = return . id - -class Monad m => TCInfo m where - getTyConInfo :: m TTCInfo - getTyConInfo = return $ M.empty - getTyConEmbed :: m TTCEmbed - getTyConEmbed = return $ M.empty - -instance Freshable m Integer => Freshable m Symbol where - fresh = liftM (tempSymbol "x") fresh - -instance Freshable m Integer => Freshable m Refa where - fresh = liftM (`RKvar` emptySubst) freshK - where freshK = liftM intKvar fresh - -instance Freshable m Integer => Freshable m [Refa] where - fresh = liftM single fresh - --- instance Monad m => Freshable m TCEmbed where - -instance Freshable m Integer => Freshable m Reft where - fresh = errorstar "fresh Reft" - true (Reft (v,_)) = return $ Reft (v, []) - refresh (Reft (_,_)) = liftM2 (curry Reft) freshVV fresh - where freshVV = liftM (vv . Just) fresh - -instance Freshable m Integer => Freshable m RReft where - fresh = errorstar "fresh RReft" - true (U r _) = liftM uTop (true r) - refresh (U r _) = liftM uTop (refresh r) - -instance (Freshable m Integer, Freshable m r, TCInfo m, Reftable r) => Freshable m (RRType r) where - fresh = errorstar "fresh RefType" - refresh = refreshRefType - true = trueRefType - -trueRefType (RAllT α t) - = liftM (RAllT α) (true t) -trueRefType (RAllP π t) - = liftM (RAllP π) (true t) -trueRefType (RFun _ t t' _) - = liftM3 rFun fresh (true t) (true t') -trueRefType (RApp c ts _ _) - = liftM (\ts -> RApp c ts truerefs top) (mapM true ts) - where truerefs = (RPoly [] . ofRSort . ptype) <$> (rTyConPs c) -trueRefType (RAppTy t t' _) - = liftM2 rAppTy (true t) (true t') -trueRefType t - = return t - - -refreshRefType :: (Freshable m Integer, Freshable m r, TCInfo m, Reftable r) - => RRType r - -> m (RRType r) -refreshRefType (RAllT α t) - = liftM (RAllT α) (refresh t) -refreshRefType (RAllP π t) - = liftM (RAllP π) (refresh t) -refreshRefType (RFun b t t' _) - | b == dummySymbol -- b == (RB F.dummySymbol) - = liftM3 rFun fresh (refresh t) (refresh t') - | otherwise - = liftM2 (rFun b) (refresh t) (refresh t') -refreshRefType (RApp rc ts _ r) - = do tyi <- getTyConInfo - tce <- getTyConEmbed - let RApp rc' _ rs _ = expandRApp tce tyi (RApp rc ts [] r) - let rπs = safeZip "refreshRef" rs (rTyConPs rc') - liftM3 (RApp rc') (mapM refresh ts) (mapM refreshRef rπs) (refresh r) -refreshRefType (RVar a r) - = liftM (RVar a) (refresh r) -refreshRefType (RAppTy t t' _) - = liftM2 rAppTy (refresh t) (refresh t') -refreshRefType t - = return t - -refreshRef :: (Freshable m Integer, Freshable m r, TCInfo m, Reftable r) - => (Ref RSort r (RRType r), PVar RSort) - -> m (Ref RSort r (RRType r)) - -refreshRef (RPoly s t, π) = liftM2 RPoly (mapM freshSym (pargs π)) (refreshRefType t) -refreshRef (RMono _ _, _) = errorstar "refreshRef: unexpected" - -freshSym s = liftM (, fst3 s) fresh diff --git a/Language/Haskell/Liquid/GhcInterface.hs b/Language/Haskell/Liquid/GhcInterface.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/GhcInterface.hs +++ /dev/null @@ -1,501 +0,0 @@ - -{-# LANGUAGE NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances, TupleSections, DeriveDataTypeable, ScopedTypeVariables #-} - -module Language.Haskell.Liquid.GhcInterface ( - - -- * extract all information needed for verification - getGhcInfo - - -- * visitors - , CBVisitable (..) - ) where - -import Bag (bagToList) -import ErrUtils -import Panic -import GHC hiding (Target) -import Text.PrettyPrint.HughesPJ -import HscTypes hiding (Target) -import TidyPgm (tidyProgram) -import Literal -import CoreSyn - -import Var -import Name (getSrcSpan) -import CoreMonad (liftIO) -import DataCon -import qualified TyCon as TC -import HscMain -import Module -import Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) -import qualified Control.Exception as Ex - -import GHC.Paths (libdir) -import System.FilePath ( replaceExtension - , dropExtension - , takeFileName - , splitFileName - , combine - , dropFileName - , normalise) - -import DynFlags -import Control.Arrow (second) -import Control.Monad (filterM, zipWithM, when, forM, liftM) -import Control.DeepSeq -import Control.Applicative hiding (empty) -import Data.Monoid hiding ((<>)) -import Data.List (intercalate, foldl', find, (\\), delete, nub) -import Data.Maybe (catMaybes, maybeToList) -import qualified Data.HashSet as S -import qualified Data.HashMap.Strict as M - -import System.Console.CmdArgs.Verbosity (whenLoud) -import System.Directory (removeFile, doesFileExist) -import Language.Fixpoint.Types hiding (Expr) -import Language.Fixpoint.Misc - -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType -import Language.Haskell.Liquid.ANFTransform -import Language.Haskell.Liquid.Bare -import Language.Haskell.Liquid.GhcMisc -import Language.Haskell.Liquid.Misc - -import Language.Haskell.Liquid.CmdLine (withPragmas) -import Language.Haskell.Liquid.Parse - -import Language.Fixpoint.Parse hiding (brackets, comma) -import Language.Fixpoint.Names -import Language.Fixpoint.Files - -import qualified Language.Haskell.Liquid.Measure as Ms - - --------------------------------------------------------------------- -getGhcInfo :: Config -> FilePath -> IO (Either ErrorResult GhcInfo) --------------------------------------------------------------------- -getGhcInfo cfg target = (Right <$> getGhcInfo' cfg target) - `Ex.catch` (\(e :: SourceError) -> handle e) - `Ex.catch` (\(e :: Error) -> handle e) - `Ex.catch` (\(e :: [Error]) -> handle e) - where - handle = return . Left . result - --- parseSpec :: (String, FilePath) -> IO (Either ErrorResult Ms.BareSpec) --- parseSpec (name, file) --- = Ex.catch (parseSpec' name file) $ \(e :: Ex.IOException) -> --- ioError $ userError $ --- printf "Hit exception: %s while parsing spec file: %s for module %s" --- (show e) file name - - -getGhcInfo' cfg0 target - = runGhc (Just libdir) $ do - liftIO $ deleteBinFilez target - addTarget =<< guessTarget target Nothing - (name,tgtSpec) <- liftIO $ parseSpec target - cfg <- liftIO $ withPragmas cfg0 $ Ms.pragmas tgtSpec - let paths = idirs cfg - df <- getSessionDynFlags - setSessionDynFlags $ updateDynFlags df (idirs cfg) - liftIO $ whenLoud $ putStrLn ("paths = " ++ show paths) - let name' = ModName Target (getModName name) - impNames <- allDepNames <$> depanal [] False - impSpecs <- getSpecs (totality cfg) target paths impNames [Spec, Hs, LHs] - impSpecs' <- forM impSpecs $ \(f,n,s) -> do - when (not $ isSpecImport n) $ - addTarget =<< guessTarget f Nothing - return (n,s) - load LoadAllTargets - modguts <- getGhcModGuts1 target - hscEnv <- getSession - coreBinds <- liftIO $ anormalize hscEnv modguts - let impVs = importVars coreBinds - let defVs = definedVars coreBinds - let useVs = readVars coreBinds - let letVs = letVars coreBinds - (spec, imps, incs) <- moduleSpec cfg (impVs ++ defVs) letVs name' modguts tgtSpec impSpecs' - liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps - hqualFiles <- moduleHquals modguts (idirs cfg) target imps incs - return $ GI hscEnv coreBinds impVs defVs useVs hqualFiles imps incs spec - -updateDynFlags df ps - = df { importPaths = ps ++ importPaths df - , libraryPaths = ps ++ libraryPaths df - , profAuto = ProfAutoCalls - , ghcLink = NoLink - , hscTarget = HscInterpreted - , ghcMode = CompManager - } `xopt_set` Opt_MagicHash - `dopt_set` Opt_ImplicitImportQualified - -mgi_namestring = moduleNameString . moduleName . mgi_module - -importVars = freeVars S.empty - -definedVars = concatMap defs - where - defs (NonRec x _) = [x] - defs (Rec xes) = map fst xes - - ------------------------------------------------------------------- --- | Extracting CoreBindings From File --------------------------- ------------------------------------------------------------------- - -getGhcModGuts1 fn = do - modGraph <- getModuleGraph - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - -- mod_guts <- modSummaryModGuts modSummary - mod_guts <- coreModule <$> (desugarModuleWithLoc =<< typecheckModule =<< parseModule modSummary) - return $! (miModGuts mod_guts) - Nothing -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts" - - --- Generates Simplified ModGuts (INLINED, etc.) but without SrcSpan -getGhcModGutsSimpl1 fn = do - modGraph <- getModuleGraph - case find ((== fn) . msHsFilePath) modGraph of - Just modSummary -> do - mod_guts <- coreModule `fmap` (desugarModule =<< typecheckModule =<< parseModule modSummary) - hsc_env <- getSession - simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts - (cg,_) <- liftIO $ tidyProgram hsc_env simpl_guts - liftIO $ putStrLn "************************* CoreGuts ****************************************" - liftIO $ putStrLn (showPpr $ cg_binds cg) - return $! (miModGuts mod_guts) { mgi_binds = cg_binds cg } - Nothing -> error "GhcInterface : getGhcModGutsSimpl1" - -peepGHCSimple fn - = do z <- compileToCoreSimplified fn - liftIO $ putStrLn "************************* peepGHCSimple Core Module ************************" - liftIO $ putStrLn $ showPpr z - liftIO $ putStrLn "************************* peepGHCSimple Bindings ***************************" - liftIO $ putStrLn $ showPpr (cm_binds z) - errorstar "Done peepGHCSimple" - -deleteBinFilez :: FilePath -> IO () -deleteBinFilez fn = mapM_ (tryIgnore "delete binaries" . removeFileIfExists) - $ (fn `replaceExtension`) `fmap` exts - where exts = ["hi", "o"] - -removeFileIfExists f = doesFileExist f >>= (`when` removeFile f) - --------------------------------------------------------------------------------- --- | Desugaring (Taken from GHC, modified to hold onto Loc in Ticks) ----------- --------------------------------------------------------------------------------- - -desugarModuleWithLoc 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 } - --------------------------------------------------------------------------------- --- | Extracting Qualifiers ----------------------------------------------------- --------------------------------------------------------------------------------- - -moduleHquals mg paths target imps incs - = do hqs <- specIncludes Hquals paths incs - hqs' <- moduleImports [Hquals] paths (mgi_namestring mg : imps) - hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target] - let rv = sortNub $ hqs'' ++ hqs ++ (snd <$> hqs') - liftIO $ whenLoud $ putStrLn $ "Reading Qualifiers From: " ++ show rv - return rv - --------------------------------------------------------------------------------- --- | Extracting Specifications (Measures + Assumptions) ------------------------ --------------------------------------------------------------------------------- - -moduleSpec cfg vars defVars target mg tgtSpec impSpecs - = do addImports impSpecs - addContext $ IIModule $ moduleName $ mgi_module mg - env <- getSession - let specs = (target,tgtSpec):impSpecs - let imps = sortNub $ impNames ++ [ symbolString x - | (_,spec) <- specs - , x <- Ms.imports spec - ] - ghcSpec <- liftIO $ makeGhcSpec cfg target vars defVars env specs - return (ghcSpec, imps, Ms.includes tgtSpec) - where - name = mgi_namestring mg - impNames = map (getModString.fst) impSpecs - addImports is - = mapM (addContext . IIDecl . qualImportDecl . getModName) (map fst is) - -allDepNames = concatMap (map declNameString . ms_textual_imps) - -declNameString = moduleNameString . unLoc . ideclName . unLoc - -depNames = map fst . dep_mods . mgi_deps -dirImportNames = map moduleName . moduleEnvKeys . mgi_dir_imps -targetName = dropExtension . takeFileName --- starName fn = combine dir ('*':f) where (dir, f) = splitFileName fn -starName = ("*" ++) - -patErrorName = "PatErr" - -getSpecs tflag target paths names exts - = do fs' <- sortNub <$> moduleImports exts paths names - patSpec <- getPatSpec paths tflag - let fs = patSpec ++ fs' - liftIO $ whenLoud $ putStrLn ("getSpecs: " ++ show fs) - transParseSpecs exts paths (S.singleton target) mempty (map snd fs) - -getPatSpec paths totalitycheck - | totalitycheck - = (map (patErrorName, )) . maybeToList <$> moduleFile paths patErrorName Spec - | otherwise - = return [] - -transParseSpecs _ _ _ specs [] - = return specs -transParseSpecs exts paths seenFiles specs newFiles - = do newSpecs <- liftIO $ mapM (\f -> addFst3 f <$> parseSpec f) newFiles - impFiles <- moduleImports exts paths $ specsImports newSpecs - let seenFiles' = seenFiles `S.union` (S.fromList newFiles) - let specs' = specs ++ map (third noTerm) newSpecs - let newFiles' = [f | (_,f) <- impFiles, not (f `S.member` seenFiles')] - transParseSpecs exts paths seenFiles' specs' newFiles' - where - specsImports ss = nub $ concatMap (map symbolString . Ms.imports . thd3) ss - noTerm spec = spec { Ms.decr=mempty, Ms.lazy=mempty } - third f (a,b,c) = (a,b,f c) - -parseSpec :: FilePath -> IO (ModName, Ms.BareSpec) -parseSpec file - = do whenLoud $ putStrLn $ "parseSpec: " ++ file - either Ex.throw return . specParser file =<< readFile file - -specParser file str - | isExtFile Spec file = specSpecificationP file str - | isExtFile Hs file = hsSpecificationP file str - | isExtFile LHs file = lhsSpecificationP file str - | otherwise = exitWithPanic $ "SpecParser: Cannot Parse File " ++ file - -moduleImports :: GhcMonad m => [Ext] -> [FilePath] -> [String] -> m [(String, FilePath)] -moduleImports exts paths names - = do modGraph <- getModuleGraph - liftM concat $ forM names $ \name -> do - map (name,) . catMaybes <$> mapM (moduleFile paths name) exts - -moduleFile :: GhcMonad m => [FilePath] -> String -> Ext -> m (Maybe FilePath) -moduleFile paths name ext - | ext `elem` [Hs, LHs] - = do mg <- getModuleGraph - case find ((==name) . moduleNameString . ms_mod_name) mg of - Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths - Just ms -> return $ normalise <$> ml_hs_file (ms_location ms) - | otherwise - = do liftIO $ getFileInDirs (extModuleName name ext) paths - -isJust Nothing = False -isJust (Just a) = True - ---moduleImports ext paths names --- = liftIO $ liftM catMaybes $ forM extNames (namePath paths) --- where extNames = (`extModuleName` ext) <$> names --- namePath paths fileName = getFileInDirs fileName paths - ---namePath_debug paths name --- = do res <- getFileInDirs name paths --- case res of --- Just p -> putStrLn $ "namePath: name = " ++ name ++ " expanded to: " ++ (show p) --- Nothing -> putStrLn $ "namePath: name = " ++ name ++ " not found in: " ++ (show paths) --- return res - -specIncludes :: GhcMonad m => Ext -> [FilePath] -> [FilePath] -> m [FilePath] -specIncludes ext paths reqs - = do let libFile = extFileName ext preludeName - let incFiles = catMaybes $ reqFile ext <$> reqs - liftIO $ forM (libFile : incFiles) (`findFileInDirs` paths) - -reqFile ext s - | isExtFile ext s - = Just s - | otherwise - = Nothing - - ------------------------------------------------------------------------------- --------------------------------- A CoreBind Visitor -------------------------- ------------------------------------------------------------------------------- - --- TODO: syb-shrinkage - -class CBVisitable a where - freeVars :: S.HashSet Var -> a -> [Var] - readVars :: a -> [Var] - letVars :: a -> [Var] - literals :: a -> [Literal] - -instance CBVisitable [CoreBind] where - freeVars env cbs = (sortNub xs) \\ ys - where xs = concatMap (freeVars env) cbs - ys = concatMap bindings cbs - - readVars = concatMap readVars - letVars = concatMap letVars - literals = concatMap literals - -instance CBVisitable CoreBind where - freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e - freeVars env (Rec xes) = concatMap (freeVars env') es - where (xs,es) = unzip xes - env' = extendEnv env xs - - readVars (NonRec _ e) = readVars e - readVars (Rec xes) = concat [x `delete` nubReadVars e |(x, e) <- xes] - where nubReadVars = sortNub . readVars - - letVars (NonRec x e) = x : letVars e - letVars (Rec xes) = xs ++ concatMap letVars es - where - (xs, es) = unzip xes - - literals (NonRec _ e) = literals e - literals (Rec xes) = concatMap literals $ map snd xes - -instance CBVisitable (Expr Var) where - freeVars = exprFreeVars - readVars = exprReadVars - letVars = exprLetVars - literals = exprLiterals - -exprFreeVars = go - where - go env (Var x) = if x `S.member` env then [] else [x] - go env (App e a) = (go env e) ++ (go env a) - go env (Lam x e) = go (extendEnv env [x]) e - go env (Let b e) = (freeVars env b) ++ (go (extendEnv env (bindings b)) e) - go env (Tick _ e) = go env e - go env (Cast e _) = go env e - go env (Case e x _ cs) = (go env e) ++ (concatMap (freeVars (extendEnv env [x])) cs) - go _ _ = [] - -exprReadVars = go - where - go (Var x) = [x] - go (App e a) = concatMap go [e, a] - go (Lam _ e) = go e - go (Let b e) = readVars b ++ go e - go (Tick _ e) = go e - go (Cast e _) = go e - go (Case e _ _ cs) = (go e) ++ (concatMap readVars cs) - go _ = [] - -exprLetVars = go - where - go (Var _) = [] - go (App e a) = concatMap go [e, a] - go (Lam x e) = x : go e - go (Let b e) = letVars b ++ go e - go (Tick _ e) = go e - go (Cast e _) = go e - go (Case e x _ cs) = x : go e ++ concatMap letVars cs - go _ = [] - -exprLiterals = go - where - go (Lit l) = [l] - go (App e a) = concatMap go [e, a] - go (Let b e) = literals b ++ go e - go (Lam _ e) = go e - go (Tick _ e) = go e - go (Cast e _) = go e - go (Case e _ _ cs) = (go e) ++ (concatMap literals cs) - go _ = [] - - -instance CBVisitable (Alt Var) where - freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e - readVars (_,_, e) = readVars e - letVars (_,xs,e) = xs ++ letVars e - literals (c,_, e) = literals c ++ literals e - - -instance CBVisitable AltCon where - freeVars _ (DataAlt dc) = dataConImplicitIds dc - freeVars _ _ = [] - readVars _ = [] - letVars _ = [] - literals (LitAlt l) = [l] - literals _ = [] - - - -extendEnv = foldl' (flip S.insert) - --- names = (map varName) . bindings --- -bindings (NonRec x _) - = [x] -bindings (Rec xes ) - = map fst xes - --------------------------------------------------------------------- ------- Strictness -------------------------------------------------- --------------------------------------------------------------------- - -instance NFData Var -instance NFData SrcSpan - -instance PPrint GhcSpec where - pprint spec = (text "******* Target Variables ********************") - $$ (pprint $ tgtVars spec) - $$ (text "******* Type Signatures *********************") - $$ (pprintLongList $ tySigs spec) - $$ (text "******* DataCon Specifications (Measure) ****") - $$ (pprintLongList $ ctor spec) - $$ (text "******* Measure Specifications **************") - $$ (pprintLongList $ meas spec) - -instance PPrint GhcInfo where - pprint info = (text "*************** Imports *********************") - $+$ (intersperse comma $ text <$> imports info) - $+$ (text "*************** Includes ********************") - $+$ (intersperse comma $ text <$> includes info) - $+$ (text "*************** Imported Variables **********") - $+$ (pprDoc $ impVars info) - $+$ (text "*************** Defined Variables ***********") - $+$ (pprDoc $ defVars info) - $+$ (text "*************** Specification ***************") - $+$ (pprint $ spec info) - $+$ (text "*************** Core Bindings ***************") - $+$ (pprint $ cbs info) - -instance Show GhcInfo where - show = showpp - -instance PPrint [CoreBind] where - pprint = pprDoc . tidyCBs - -instance PPrint TargetVars where - pprint AllVars = text "All Variables" - pprint (Only vs) = text "Only Variables: " <+> pprint vs - -pprintLongList = brackets . vcat . map pprint - ------------------------------------------------------------------------- --- 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") - . concatMap errMsgErrors - . bagToList - . srcErrorMessages - -errMsgErrors e = [ ErrGhc l (pprint e) | l <- errMsgSpans e ] - diff --git a/Language/Haskell/Liquid/GhcMisc.hs b/Language/Haskell/Liquid/GhcMisc.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/GhcMisc.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module contains a wrappers and utility functions for --- accessing GHC module information. It should NEVER depend on --- ANY module inside the Language.Haskell.Liquid.* tree. - -module Language.Haskell.Liquid.GhcMisc where - -import Debug.Trace - -import Kind (superKind) -import CoreSyn hiding (Expr) -import CostCentre -import FamInstEnv (FamInst) -import GHC hiding (L) -import HscTypes (Dependencies, ImportedMods, ModGuts(..)) -import SrcLoc (srcSpanFile, srcSpanStartLine, srcSpanStartCol) - -import Language.Fixpoint.Misc (errorstar, stripParens) -import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos) -import Language.Fixpoint.Types hiding (SESearch(..)) -import Name (mkInternalName, getSrcSpan) -import OccName (mkTyVarOcc, mkTcOcc) -import Unique -import Finder (findImportedModule, cannotFindModule) -import DynamicLoading -import ErrUtils -import Exception -import Panic (GhcException(..), throwGhcException) -import RnNames (gresFromAvails) -import HscMain -import HscTypes (HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv) -import FastString -import TcRnDriver -import OccName - - -import RdrName -import Type (liftedTypeKind) -import TypeRep -import Var --- import TyCon (mkSuperKindTyCon) -import qualified TyCon as TC -import qualified DataCon as DC -import FastString (uniq, unpackFS, fsLit) -import Data.Char (isLower, isSpace) -import Data.Maybe -import Data.Hashable -import qualified Data.HashSet as S -import qualified Data.List as L -import Control.Applicative ((<$>)) -import Control.Arrow (second) -import Control.Exception (assert, throw) -import Outputable (Outputable (..), text, ppr) -import qualified Outputable as Out -import DynFlags --- import Language.Haskell.Liquid.Types - --- import qualified Pretty as P -import qualified Text.PrettyPrint.HughesPJ as PJ - ------------------------------------------------------------------------ ---------------- Datatype For Holding GHC ModGuts ---------------------- ------------------------------------------------------------------------ - -data MGIModGuts = MI { - mgi_binds :: !CoreProgram - , mgi_module :: !Module - , mgi_deps :: !Dependencies - , mgi_dir_imps :: !ImportedMods - , mgi_rdr_env :: !GlobalRdrEnv - , mgi_tcs :: ![TyCon] - , mgi_fam_insts :: ![FamInst] - } - -miModGuts mg = MI { - mgi_binds = mg_binds mg - , mgi_module = mg_module mg - , mgi_deps = mg_deps mg - , mgi_dir_imps = mg_dir_imps mg - , mgi_rdr_env = mg_rdr_env mg - , mgi_tcs = mg_tcs mg - , mgi_fam_insts = mg_fam_insts mg - } - ------------------------------------------------------------------------ ---------------- Generic Helpers for Encoding Location ----------------- ------------------------------------------------------------------------ - -srcSpanTick :: Module -> SrcSpan -> Tickish a -srcSpanTick m loc - = ProfNote (AllCafsCC m loc) False True - -tickSrcSpan :: Outputable a => Tickish a -> SrcSpan -tickSrcSpan (ProfNote (AllCafsCC _ loc) _ _) - = loc -tickSrcSpan z - = errorstar $ "tickSrcSpan: unhandled tick: " ++ showPpr z - ------------------------------------------------------------------------ ---------------- Generic Helpers for Accessing GHC Innards ------------- ------------------------------------------------------------------------ - -stringTyVar :: String -> TyVar -stringTyVar s = mkTyVar name liftedTypeKind - where name = mkInternalName (mkUnique 'x' 24) occ noSrcSpan - occ = mkTcOcc s - -stringTyCon :: Char -> Int -> String -> TyCon -stringTyCon c n s = TC.mkKindTyCon name superKind - where - name = mkInternalName (mkUnique c n) occ noSrcSpan - occ = mkTyVarOcc $ assert (validTyVar s) s - -hasBaseTypeVar = isBaseType . varType - --- same as Constraint isBase -isBaseType (TyVarTy _) = True -isBaseType (TyConApp _ ts) = all isBaseType ts -isBaseType (FunTy t1 t2) = isBaseType t1 && isBaseType t2 -isBaseType _ = False -validTyVar :: String -> Bool -validTyVar s@(c:_) = isLower c && all (not . isSpace) s -validTyVar _ = False - -tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α) - -tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x - -pprShow = text . show - - -tidyCBs = map unTick - -unTick (NonRec b e) = NonRec b (unTickExpr e) -unTick (Rec bs) = Rec $ map (second unTickExpr) bs - -unTickExpr (App e a) = App (unTickExpr e) (unTickExpr a) -unTickExpr (Lam b e) = Lam b (unTickExpr e) -unTickExpr (Let b e) = Let (unTick b) (unTickExpr e) -unTickExpr (Case e b t as) = Case (unTickExpr e) b t (map unTickAlt as) - where unTickAlt (a, b, e) = (a, b, unTickExpr e) -unTickExpr (Cast e c) = Cast (unTickExpr e) c -unTickExpr (Tick _ e) = unTickExpr e -unTickExpr x = x - ------------------------------------------------------------------------ ------------------- Generic Helpers for DataConstructors --------------- ------------------------------------------------------------------------ - -getDataConVarUnique v - | isId v && isDataConWorkId v = getUnique $ idDataCon v - | otherwise = getUnique v - - -newtype Loc = L (Int, Int) deriving (Eq, Ord, Show) - -instance Hashable Loc where - hashWithSalt i (L z) = hashWithSalt i z - ---instance (Uniquable a) => Hashable a where - -instance Hashable SrcSpan where - hashWithSalt i (UnhelpfulSpan s) = hashWithSalt i (uniq s) - hashWithSalt i (RealSrcSpan s) = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s) - -instance Outputable a => Outputable (S.HashSet a) where - ppr = ppr . S.toList - -------------------------------------------------------- - -toFixSDoc = PJ.text . PJ.render . toFix -sDocDoc = PJ.text . showSDoc -pprDoc = sDocDoc . ppr - --- Overriding Outputable functions because they now require DynFlags! -showPpr = Out.showPpr tracingDynFlags -showSDoc = Out.showSDoc tracingDynFlags -showSDocDump = Out.showSDocDump tracingDynFlags - -typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr - -instance Fixpoint Var where - toFix = pprDoc - -instance Fixpoint Name where - toFix = pprDoc - -instance Fixpoint Type where - toFix = pprDoc - - -sourcePosSrcSpan :: SourcePos -> SrcSpan -sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc - -sourcePosSrcLoc :: SourcePos -> SrcLoc -sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col - where - file = sourceName p - line = sourceLine p - col = sourceColumn p - -srcSpanSourcePos :: SrcSpan -> SourcePos -srcSpanSourcePos (UnhelpfulSpan _) = dummyPos -srcSpanSourcePos (RealSrcSpan s) = realSrcSpanSourcePos s - -srcSpanStartLoc l = L (srcSpanStartLine l, srcSpanStartCol l) -srcSpanEndLoc l = L (srcSpanEndLine l, srcSpanEndCol l) -oneLine l = srcSpanStartLine l == srcSpanEndLine l -lineCol l = (srcSpanStartLine l, srcSpanStartCol l) -dummyPos :: SourcePos -dummyPos = newPos "?" 0 0 - -realSrcSpanSourcePos :: RealSrcSpan -> SourcePos -realSrcSpanSourcePos s = newPos file line col - where - file = unpackFS $ srcSpanFile s - line = srcSpanStartLine s - col = srcSpanStartCol s - -getSourcePos = srcSpanSourcePos . getSrcSpan - - -collectArguments n e = if length xs > n then take n xs else xs - where (vs', e') = collectValBinders' $ snd $ collectTyBinders e - vs = fst $ collectValBinders $ ignoreLetBinds e' - xs = vs' ++ vs - -collectValBinders' expr = go [] expr - where - go tvs (Lam b e) | isTyVar b = go tvs e - go tvs (Lam b e) | isId b = go (b:tvs) e - go tvs e = (reverse tvs, e) - -ignoreLetBinds e@(Let (NonRec x xe) e') - = ignoreLetBinds e' -ignoreLetBinds e - = e - -isDictionary x = L.isPrefixOf "$d" (showPpr x) -isInternal x = L.isPrefixOf "$" (showPpr x) - - -instance Hashable Var where - hashWithSalt = uniqueHash - -instance Hashable TyCon where - hashWithSalt = uniqueHash - -uniqueHash i = hashWithSalt i . getKey . getUnique - --- slightly modified version of DynamicLoading.lookupRdrNameInModule -lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) -lookupRdrName hsc_env mod_name rdr_name = do - -- First find the package the module resides in by searching exposed packages and home modules - found_module <- findImportedModule hsc_env mod_name Nothing - case found_module of - Found _ mod -> do - -- Find the exports of the module - (_, mb_iface) <- getModuleInterface hsc_env mod - case mb_iface of - Just iface -> do - -- Try and find the required name in the exports - let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name - , is_qual = False, is_dloc = noSrcSpan } - provenance = Imported [ImpSpec decl_spec ImpAll] - env = case mi_globals iface of - Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface)) - Just e -> e - case lookupGRE_RdrName rdr_name env of - [gre] -> return (Just (gre_name gre)) - [] -> return Nothing - _ -> Out.panic "lookupRdrNameInModule" - Nothing -> throwCmdLineErrorS dflags $ Out.hsep [Out.ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where dflags = hsc_dflags hsc_env - throwCmdLineErrorS dflags = throwCmdLineError . Out.showSDoc dflags - throwCmdLineError = throwGhcException . CmdLineError - - -addContext m = getContext >>= setContext . (m:) - -qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True } diff --git a/Language/Haskell/Liquid/Measure.hs b/Language/Haskell/Liquid/Measure.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Measure.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} - -module Language.Haskell.Liquid.Measure ( - Spec (..) - , BareSpec - , MSpec (..) - , Measure (..) - , Def (..) - , Body (..) - , mkM, mkMSpec - , qualifySpec - , mapTy - , dataConTypes - , defRefType - ) where - -import GHC hiding (Located) -import Var -import qualified Outputable as O -import Text.PrettyPrint.HughesPJ hiding (first) -import Text.Printf (printf) -import DataCon -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.Monoid hiding ((<>)) -import Data.List (foldl1') -import Data.Either (partitionEithers) -import Data.Bifunctor -import Control.Applicative ((<$>)) -import Control.Exception (assert) - -import Language.Fixpoint.Misc -import Language.Fixpoint.Types -import Language.Haskell.Liquid.GhcMisc -import Language.Haskell.Liquid.Types hiding (GhcInfo(..), GhcSpec (..)) -import Language.Haskell.Liquid.RefType - --- MOVE TO TYPES -type BareSpec = Spec BareType Symbol - -data Spec ty bndr = Spec { - measures :: ![Measure ty bndr] -- ^ User-defined properties for ADTs - , sigs :: ![(LocSymbol, ty)] -- ^ Imported functions and types - , invariants :: ![Located ty] -- ^ Data type invariants - , imports :: ![Symbol] -- ^ Loaded spec module names - , dataDecls :: ![DataDecl] -- ^ Predicated data definitions - , includes :: ![FilePath] -- ^ Included qualifier files - , aliases :: ![RTAlias String BareType] -- ^ RefType aliases - , paliases :: ![RTAlias Symbol Pred] -- ^ Refinement/Predicate aliases - , embeds :: !(TCEmb (Located String)) -- ^ GHC-Tycon-to-fixpoint Tycon map - , qualifiers :: ![Qualifier] -- ^ Qualifiers in source/spec files - , decr :: ![(LocSymbol, [Int])] -- ^ Information on decreasing arguments - , lvars :: ![(LocSymbol)] -- ^ Variables that should be checked in the environment they are used - , lazy :: !(S.HashSet Symbol) -- ^ Ignore Termination Check in these Functions - , pragmas :: ![Located String] -- ^ Command-line configurations passed in through source - } - - --- MOVE TO TYPES -data MSpec ty ctor = MSpec { - ctorMap :: M.HashMap Symbol [Def ctor] - , measMap :: M.HashMap Symbol (Measure ty ctor) - } - -instance Monoid (MSpec ty ctor) where - mempty = MSpec M.empty M.empty - - (MSpec c1 m1) `mappend` (MSpec c2 m2) = - MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) - - --- MOVE TO TYPES -data Measure ty ctor = M { - name :: LocSymbol - , sort :: ty - , eqns :: [Def ctor] - } - --- MOVE TO TYPES -data Def ctor - = Def { - measure :: LocSymbol - , ctor :: ctor - , binds :: [Symbol] - , body :: Body - } deriving (Show) - --- MOVE TO TYPES -data Body - = E Expr -- ^ Measure Refinement: {v | v = e } - | P Pred -- ^ Measure Refinement: {v | (? v) <=> p } - | R Symbol Pred -- ^ Measure Refinement: {v | p} - deriving (Show) - -instance Subable (Measure ty ctor) where - syms (M _ _ es) = concatMap syms es - substa f (M n s es) = M n s $ substa f <$> es - substf f (M n s es) = M n s $ substf f <$> es - subst su (M n s es) = M n s $ subst su <$> es - -instance Subable (Def ctor) where - syms (Def _ _ _ bd) = syms bd - substa f (Def m c b bd) = Def m c b $ substa f bd - substf f (Def m c b bd) = Def m c b $ substf f bd - subst su (Def m c b bd) = Def m c b $ subst su bd - -instance Subable Body where - syms (E e) = syms e - syms (P e) = syms e - syms (R s e) = s:syms e - - substa f (E e) = E $ substa f e - substa f (P e) = P $ substa f e - substa f (R s e) = R s $ substa f e - - substf f (E e) = E $ substf f e - substf f (P e) = P $ substf f e - substf f (R s e) = R s $ substf f e - - subst su (E e) = E $ subst su e - subst su (P e) = P $ subst su e - subst su (R s e) = R s $ subst su e - -qualifySpec name sp = sp { sigs = [ (qualifySymbol name <$> x, t) | (x, t) <- sigs sp] } - -mkM :: LocSymbol -> ty -> [Def bndr] -> Measure ty bndr -mkM name typ eqns - | all ((name ==) . measure) eqns - = M name typ eqns - | otherwise - = errorstar $ "invalid measure definition for " ++ (show name) - --- mkMSpec :: [Measure ty Symbol] -> MSpec ty Symbol -mkMSpec ms = MSpec cm mm - where - cm = groupMap ctor $ concatMap eqns ms' - mm = M.fromList [(val $ name m, m) | m <- ms' ] - ms' = checkDuplicateMeasure ms - -- ms' = checkFail "Duplicate Measure Definition" (distinct . fmap name) ms - -checkDuplicateMeasure ms - = case M.toList dups of - [] -> ms - mms -> errorstar $ concatMap err mms - where - gms = group [(name m , m) | m <- ms] - dups = M.filter ((1 <) . length) gms - err (m,ms) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp m) (showpp $ map (loc . name) ms) - - - - --- MOVE TO TYPES -instance Monoid (Spec ty bndr) where - mappend (Spec xs ys invs zs ds is as ps es qs drs lvs ss gs) - (Spec xs' ys' invs' zs' ds' is' as' ps' es' qs' drs' lvs' ss' gs') - = Spec (xs ++ xs') - (ys ++ ys') - (invs ++ invs') - (sortNub (zs ++ zs')) - (ds ++ ds') - (sortNub (is ++ is')) - (as ++ as') - (ps ++ ps') - (M.union es es') - (qs ++ qs') - (drs ++ drs') - (lvs ++ lvs') - (S.union ss ss') - (gs ++ gs') - mempty = Spec [] [] [] [] [] [] [] [] M.empty [] [] [] S.empty [] - --- MOVE TO TYPES -instance Functor Def where - fmap f def = def { ctor = f (ctor def) } - --- MOVE TO TYPES -instance Functor (Measure t) where - fmap f (M n s eqs) = M n s (fmap (fmap f) eqs) - --- MOVE TO TYPES -instance Functor (MSpec t) where - fmap f (MSpec cm mm) = MSpec (fc cm) (fm mm) - where fc = fmap $ fmap $ fmap f - fm = fmap $ fmap f - --- MOVE TO TYPES -instance Bifunctor Measure where - first f (M n s eqs) = M n (f s) eqs - second f (M n s eqs) = M n s (fmap f <$> eqs) - --- MOVE TO TYPES -instance Bifunctor MSpec where - first f (MSpec cm mm) = MSpec cm (fmap (first f) mm) - second = fmap - --- MOVE TO TYPES -instance Bifunctor Spec where - first f (Spec ms ss is x0 x1 x2 x3 x4 x5 x6 x7 x7a x8 x9) - = Spec { measures = first f <$> ms - , sigs = second f <$> ss - , invariants = fmap f <$> is - , imports = x0 - , dataDecls = x1 - , includes = x2 - , aliases = x3 - , paliases = x4 - , embeds = x5 - , qualifiers = x6 - , decr = x7 - , lvars = x7a - , lazy = x8 - , pragmas = x9 - } - second f (Spec ms x0 x1 x2 x3 x4 x5 x5' x6 x7 x8 x8a x9 x10) - = Spec { measures = fmap (second f) ms - , sigs = x0 - , invariants = x1 - , imports = x2 - , dataDecls = x3 - , includes = x4 - , aliases = x5 - , paliases = x5' - , embeds = x6 - , qualifiers = x7 - , decr = x8 - , lvars = x8a - , lazy = x9 - , pragmas = x10 - } - --- MOVE TO TYPES -instance PPrint Body where - pprint (E e) = pprint e - pprint (P p) = pprint p - pprint (R v p) = braces (pprint v <+> text "|" <+> pprint p) - --- instance PPrint a => Fixpoint (PPrint a) where --- toFix (BDc c) = toFix c --- toFix (BTup n) = parens $ toFix n - --- MOVE TO TYPES -instance PPrint a => PPrint (Def a) where - pprint (Def m c bs body) = pprint m <> text " " <> cbsd <> text " = " <> pprint body - where cbsd = parens (pprint c <> hsep (pprint `fmap` bs)) - --- MOVE TO TYPES -instance (PPrint t, PPrint a) => PPrint (Measure t a) where - pprint (M n s eqs) = pprint n <> text "::" <> pprint s - $$ vcat (pprint `fmap` eqs) - --- MOVE TO TYPES -instance (PPrint t, PPrint a) => PPrint (MSpec t a) where - pprint = vcat . fmap pprint . fmap snd . M.toList . measMap - --- MOVE TO TYPES -instance PPrint (Measure t a) => Show (Measure t a) where - show = showpp - --- MOVE TO TYPES -mapTy :: (tya -> tyb) -> Measure tya c -> Measure tyb c -mapTy f (M n ty eqs) = M n (f ty) eqs - -dataConTypes :: MSpec RefType DataCon -> ([(Var, RefType)], [(LocSymbol, RefType)]) -dataConTypes s = (ctorTys, measTys) - where - measTys = [(name m, sort m) | m <- M.elems $ measMap s] - ctorTys = concatMap mkDataConIdsTy [(defsVar ds, defsTy ds) | (_, ds) <- M.toList $ ctorMap s] - defsTy = foldl1' meet . fmap defRefType - defsVar = ctor . safeHead "defsVar" - -defRefType :: Def DataCon -> RefType -defRefType (Def f dc xs body) = mkArrow as [] xts t' - where - as = RTV <$> dataConUnivTyVars dc - xts = safeZip msg xs $ ofType `fmap` dataConOrigArgTys dc - t' = refineWithCtorBody dc f body t - t = ofType $ dataConOrigResTy dc - msg = "defRefType dc = " ++ showPpr dc - - -refineWithCtorBody dc (Loc _ f) body t = - case stripRTypeBase t of - Just (Reft (v, _)) -> - strengthen t $ Reft (v, [RConc $ bodyPred (EApp f [eVar v]) body]) - Nothing -> - errorstar $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc - - -bodyPred :: Expr -> Body -> Pred -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) - - diff --git a/Language/Haskell/Liquid/Misc.hs b/Language/Haskell/Liquid/Misc.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Misc.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Language.Haskell.Liquid.Misc where - -import Control.Applicative -import System.FilePath - -import Language.Fixpoint.Misc (errorstar) - -import Paths_liquidhaskell - -safeIndex err n ls - | n >= length ls - = errorstar err - | otherwise - = ls !! n - -safeFromJust err (Just x) = x -safeFromJust err _ = errorstar err - -addFst3 a (b, c) = (a, b, c) -dropFst3 (_, x, y) = (x, y) - -replaceN n y ls = [if i == n then y else x | (x, i) <- zip ls [0..]] - -mapSndM f (x, y) = return . (x,) =<< f y - -firstM f (a,b) = (,b) <$> f a -secondM f (a,b) = (a,) <$> f b - -first3M f (a,b,c) = (,b,c) <$> f a -second3M f (a,b,c) = (a,,c) <$> f b -third3M f (a,b,c) = (a,b,) <$> f c - -zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : (zip4 xs1 xs2 xs3 xs4) -zip4 _ _ _ _ = [] - -getIncludeDir = dropFileName <$> getDataFileName "include/Prelude.spec" -getCssPath = getDataFileName "syntax/liquid.css" -getHqBotPath = getDataFileName "include/Bot.hquals" diff --git a/Language/Haskell/Liquid/Parse.hs b/Language/Haskell/Liquid/Parse.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Parse.hs +++ /dev/null @@ -1,719 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections #-} - -module Language.Haskell.Liquid.Parse - (hsSpecificationP, lhsSpecificationP, specSpecificationP) - where - -import Control.Monad -import Text.Parsec -import Text.Parsec.Error (newErrorMessage, errorPos, Message (..)) -import Text.Parsec.Pos (newPos) - -import qualified Text.Parsec.Token as Token -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S - -import Control.Applicative ((<$>), (<*), (<*>)) -import Data.Char (toLower, isLower, isSpace, isAlpha) -import Data.List (partition) -import Data.Monoid (mempty) - -import GHC (mkModuleName, ModuleName) -import Text.PrettyPrint.HughesPJ (text) - -import Language.Preprocessor.Unlit (unlit) - -import Language.Fixpoint.Types - -import Language.Haskell.Liquid.GhcMisc -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType -import qualified Language.Haskell.Liquid.Measure as Measure -import Language.Fixpoint.Names (listConName, propConName, tupConName) -import Language.Fixpoint.Misc hiding (dcolon, dot) -import Language.Fixpoint.Parse - ----------------------------------------------------------------------------- --- Top Level Parsing API --------------------------------------------------- ----------------------------------------------------------------------------- - -------------------------------------------------------------------------------- -hsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) -------------------------------------------------------------------------------- - -hsSpecificationP = parseWithError $ do - S name <- try (lookAhead $ skipMany (commentP >> spaces) - >> reserved "module" >> symbolP) - <|> return (S "Main") - liftM (mkSpec (ModName SrcImport $ mkModuleName name)) $ specWraps specP - -------------------------------------------------------------------------------- -lhsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) -------------------------------------------------------------------------------- - -lhsSpecificationP sn s = hsSpecificationP sn $ unlit sn s - -commentP = simpleComment (string "{-") (string "-}") - <|> simpleComment (string "--") newlineP - <|> simpleComment (string "\\") newlineP - <|> simpleComment (string "#") newlineP - -simpleComment open close = open >> manyTill anyChar (try close) - -newlineP = try (string "\r\n") <|> string "\n" <|> string "\r" - - --- | Used to parse .spec files - --------------------------------------------------------------------------- -specSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) --------------------------------------------------------------------------- -specSpecificationP = parseWithError specificationP - -specificationP :: Parser (ModName, Measure.BareSpec) -specificationP - = do reserved "module" - reserved "spec" - S name <- symbolP - reserved "where" - xs <- grabs (specP <* whiteSpace) - return $ mkSpec (ModName SpecImport $ mkModuleName name) xs - ---------------------------------------------------------------------------- -parseWithError :: Parser a -> SourceName -> String -> Either Error a ---------------------------------------------------------------------------- -parseWithError parser f s - = case runParser (remainderP (whiteSpace >> parser)) 0 f s of - Left e -> Left $ parseErrorError f e - Right (r, "") -> Right $ r - Right (_, rem) -> Left $ parseErrorError f $ remParseError f s rem - ---------------------------------------------------------------------------- -parseErrorError :: SourceName -> ParseError -> Error ---------------------------------------------------------------------------- -parseErrorError f e = ErrParse p msg e - where - p = sourcePosSrcSpan $ errorPos e - msg = text $ "Error Parsing Specification from: " ++ f - ---------------------------------------------------------------------------- -remParseError :: SourceName -> String -> String -> ParseError ---------------------------------------------------------------------------- -remParseError f s r = newErrorMessage msg $ newPos f line col - where - msg = Message "Leftover while parsing" - (line, col) = remLineCol s r - -remLineCol :: String -> String -> (Int, Int) -remLineCol src rem = (line, col) - where - line = 1 + srcLine - remLine - srcLine = length srcLines - remLine = length remLines - col = srcCol - remCol - srcCol = length $ srcLines !! (line - 1) - remCol = length $ remLines !! 0 - srcLines = lines $ src - remLines = lines $ rem - - - ----------------------------------------------------------------------------------- --- Lexer Tokens ------------------------------------------------------------------ ----------------------------------------------------------------------------------- - -dot = Token.dot lexer -braces = Token.braces lexer -angles = Token.angles lexer -stringLiteral = Token.stringLiteral lexer - ----------------------------------------------------------------------------------- --- BareTypes --------------------------------------------------------------------- ----------------------------------------------------------------------------------- - --- | The top-level parser for "bare" refinement types. If refinements are --- not supplied, then the default "top" refinement is used. - -bareTypeP :: Parser BareType - -bareTypeP - = try bareFunP - <|> bareAllP - <|> bareAllExprP - <|> bareExistsP - <|> bareAtomP - -bareArgP - = bareAtomP - <|> parens bareTypeP - -bareAtomP - = refP bbaseP - <|> try (dummyP (bbaseP <* spaces)) - -bbaseP :: Parser (Reft -> BareType) -bbaseP - = liftM2 bLst (brackets bareTypeP) predicatesP - <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP - <|> try (liftM2 bAppTy lowerIdP bareTyArgP) - <|> try (liftM2 bRVar lowerIdP monoPredicateP) - <|> liftM3 bCon upperIdP predicatesP (sepBy bareTyArgP blanks) - -bbaseNoAppP :: Parser (Reft -> BareType) -bbaseNoAppP - = liftM2 bLst (brackets bareTypeP) predicatesP - <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP - <|> try (liftM3 bCon upperIdP predicatesP (return [])) - <|> liftM2 bRVar lowerIdP monoPredicateP - -bareTyArgP - = try (braces $ liftM RExprArg exprP) - <|> try bareAtomNoAppP - <|> try (parens bareTypeP) - -bareAtomNoAppP - = refP bbaseNoAppP - <|> try (dummyP (bbaseNoAppP <* spaces)) - -bareAllExprP - = do reserved "forall" - zs <- brackets $ sepBy1 exBindP comma - dot - t <- bareTypeP - return $ foldr (uncurry RAllE) t zs - -bareExistsP - = do reserved "exists" - zs <- brackets $ sepBy1 exBindP comma - dot - t <- bareTypeP - return $ foldr (uncurry REx) t zs - -exBindP - = xyP binderP colon bareTypeP - - -bareAllP - = do reserved "forall" - as <- many tyVarIdP -- sepBy1 tyVarIdP comma - ps <- predVarDefsP - dot - t <- bareTypeP - return $ foldr RAllT (foldr RAllP t ps) as - -tyVarIdP :: Parser String -tyVarIdP = condIdP alphanums (isLower . head) - where alphanums = ['a'..'z'] ++ ['0'..'9'] - -predVarDefsP - = try (angles $ sepBy1 predVarDefP comma) - <|> return [] - -predVarDefP - = liftM3 bPVar predVarIdP dcolon predVarTypeP - -predVarIdP - = stringSymbol <$> tyVarIdP - -bPVar p _ xts = PV p τ τxs - where (_, τ) = safeLast "bPVar last" xts - τxs = [ (τ, x, EVar x) | (x, τ) <- init xts ] - -predVarTypeP :: Parser [(Symbol, BSort)] -predVarTypeP = do t <- bareTypeP - let (xs, ts, t') = bkArrow $ thd3 $ bkUniv $ t - if isPropBareType t' - then return $ zip xs (toRSort <$> ts) - else parserFail $ "Predicate Variable with non-Prop output sort: " ++ showpp t - - -xyP lP sepP rP - = liftM3 (\x _ y -> (x, y)) lP (spaces >> sepP) rP - -data ArrowSym = ArrowFun | ArrowPred - -arrowP - = (reserved "->" >> return ArrowFun) - <|> (reserved "=>" >> return ArrowPred) - -positionNameP = dummyNamePos <$> getPosition - -dummyNamePos pos = "dummy." ++ name ++ ['.'] ++ line ++ ['.'] ++ col - where - name = san <$> sourceName pos - line = show $ sourceLine pos - col = show $ sourceColumn pos - san '/' = '.' - san c = toLower c - -bareFunP - = do b <- try bindP <|> dummyBindP - t1 <- bareArgP - a <- arrowP - t2 <- bareTypeP - return $ bareArrow b t1 a t2 - -dummyBindP - = tempSymbol "db" <$> freshIntP - -- = stringSymbol <$> positionNameP - -bbindP = lowerIdP <* dcolon - -bindP = liftM stringSymbol (lowerIdP <* colon) - -bareArrow b t1 ArrowFun t2 - = rFun b t1 t2 -bareArrow _ t1 ArrowPred t2 - = foldr (rFun dummySymbol) t2 (getClasses t1) - - -isPropBareType (RApp tc [] _ _) = tc == propConName -isPropBareType _ = False - - -getClasses (RApp tc ts _ _) - | isTuple tc - = getClass `fmap` ts -getClasses t - = [getClass t] -getClass (RApp c ts _ _) - = RCls c ts -getClass t - = errorstar $ "Cannot convert " ++ (show t) ++ " to Class" - -dummyP :: Monad m => m (Reft -> b) -> m b -dummyP fm - = fm `ap` return dummyReft - -refP :: Parser (Reft -> a) -> Parser a -refP kindP - = braces $ do - v <- symbolP - colon - t <- kindP - reserved "|" - ras <- refasP - return $ t (Reft (v, ras)) - -symsP - = do reserved "\\" - ss <- sepBy symbolP spaces - reserved "->" - return $ (, dummyRSort) <$> ss - <|> return [] - -refasP :: Parser [Refa] -refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) - <|> liftM ((:[]) . RConc) predP - -predicatesP - = try (angles $ sepBy1 predicate1P comma) - <|> return [] - -predicate1P - = try (liftM2 RPoly symsP (refP bbaseP)) - <|> liftM (RMono [] . predUReft) monoPredicate1P - <|> (braces $ liftM2 bRPoly symsP' refasP) - where - symsP' = do ss <- symsP - fs <- mapM refreshSym (fst <$> ss) - return $ zip ss fs - refreshSym s = liftM (intSymbol (symbolString s)) freshIntP - -monoPredicateP - = try (angles monoPredicate1P) - <|> return mempty - -monoPredicate1P - = try (reserved "True" >> return mempty) - <|> try (liftM pdVar (parens predVarUseP)) - <|> liftM pdVar predVarUseP - -predVarUseP - = do p <- predVarIdP - xs <- sepBy exprP spaces - return $ PV p dummyTyId [ (dummyTyId, dummySymbol, x) | x <- xs ] - - ------------------------------------------------------------------------- ------------------------ Wrapped Constructors --------------------------- ------------------------------------------------------------------------- - -bRPoly [] _ = errorstar "Parse.bRPoly empty list" -bRPoly syms' expr = RPoly ss $ bRVar dummyName top r - where (ss, (v, _)) = (init syms, last syms) - syms = [(y, s) | ((_, s), y) <- syms'] - su = mkSubst [(x, EVar y) | ((x, _), y) <- syms'] - r = su `subst` Reft(v, expr) - -bRVar α p r = RVar α (U r p) -bLst t rs r = RApp listConName [t] rs (reftUReft r) - -bTup [t] _ r | isTauto r = t - | otherwise = t `strengthen` (reftUReft r) -bTup ts rs r = RApp tupConName ts rs (reftUReft r) - -bCon b [RMono _ r1] [] r = RApp b [] [] (r1 `meet` (reftUReft r)) -bCon b rs ts r = RApp b ts rs (reftUReft r) - -bAppTy v t r = RAppTy (RVar v top) t (reftUReft r) - - - - -reftUReft = (`U` mempty) -predUReft = (U dummyReft) -dummyReft = top -dummyTyId = "" -dummyRSort = ROth "dummy" - ------------------------------------------------------------------- ---------------------------- Measures ----------------------------- ------------------------------------------------------------------- - -data Pspec ty ctor - = Meas (Measure.Measure ty ctor) - | Assm (LocSymbol, ty) - | Assms ([LocSymbol], ty) - | Impt Symbol - | DDecl DataDecl - | Incl FilePath - | Invt (Located ty) - | Alias (RTAlias String BareType) - | PAlias (RTAlias Symbol Pred) - | Embed (Located String, FTycon) - | Qualif Qualifier - | Decr (LocSymbol, [Int]) - | LVars LocSymbol - | Lazy Symbol - | Pragma (Located String) - --- mkSpec :: String -> [Pspec ty LocSymbol] -> Measure.Spec ty LocSymbol -mkSpec name xs = (name,) - $ Measure.qualifySpec (getModString name) - $ Measure.Spec - { Measure.measures = [m | Meas m <- xs] - , Measure.sigs = [a | Assm a <- xs] - ++ [(y, t) | Assms (ys, t) <- xs, y <- ys] - , Measure.invariants = [t | Invt t <- xs] - , Measure.imports = [i | Impt i <- xs] - , Measure.dataDecls = [d | DDecl d <- xs] - , Measure.includes = [q | Incl q <- xs] - , Measure.aliases = [a | Alias a <- xs] - , Measure.paliases = [p | PAlias p <- xs] - , Measure.embeds = M.fromList [e | Embed e <- xs] - , Measure.qualifiers = [q | Qualif q <- xs] - , Measure.decr = [d | Decr d <- xs] - , Measure.lvars = [d | LVars d <- xs] - , Measure.lazy = S.fromList [s | Lazy s <- xs] - , Measure.pragmas = [s | Pragma s <- xs] - } - -specP :: Parser (Pspec BareType Symbol) -specP - = try (reserved "assume" >> liftM Assm tyBindP ) - <|> (reserved "assert" >> liftM Assm tyBindP ) - <|> (reserved "measure" >> liftM Meas measureP ) - <|> (reserved "import" >> liftM Impt symbolP ) - <|> (reserved "data" >> liftM DDecl dataDeclP ) - <|> (reserved "include" >> liftM Incl filePathP ) - <|> (reserved "invariant" >> liftM Invt invariantP) - <|> (reserved "type" >> liftM Alias aliasP ) - <|> (reserved "predicate" >> liftM PAlias paliasP ) - <|> (reserved "embed" >> liftM Embed embedP ) - <|> (reserved "qualif" >> liftM Qualif qualifierP) - <|> (reserved "Decrease" >> liftM Decr decreaseP ) - <|> (reserved "LAZYVAR" >> liftM LVars lazyVarP ) - <|> (reserved "Strict" >> liftM Lazy lazyP ) - <|> (reserved "Lazy" >> liftM Lazy lazyP ) - <|> (reserved "LIQUID" >> liftM Pragma pragmaP ) - <|> ({- DEFAULT -} liftM Assms tyBindsP ) - -pragmaP :: Parser (Located String) -pragmaP = locParserP $ stringLiteral - -lazyP :: Parser Symbol -lazyP = binderP - -lazyVarP :: Parser LocSymbol -lazyVarP = locParserP binderP - -decreaseP :: Parser (LocSymbol, [Int]) -decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer)) - where f = ((\n -> fromInteger n - 1) <$>) - -filePathP :: Parser FilePath -filePathP = angles $ many1 pathCharP - where - pathCharP = choice $ char <$> pathChars - pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/'] - -tyBindsP :: Parser ([LocSymbol], BareType) -tyBindsP = xyP (sepBy (locParserP binderP) comma) dcolon genBareTypeP - -tyBindP :: Parser (LocSymbol, BareType) -tyBindP = xyP (locParserP binderP) dcolon genBareTypeP - -locParserP :: Parser a -> Parser (Located a) -locParserP p = liftM2 Loc getPosition p - -invariantP = locParserP genBareTypeP - -genBareTypeP - = bareTypeP -- liftM generalize bareTypeP - -embedP - = xyP (locParserP upperIdP) (reserved "as") fTyConP - - -aliasP = rtAliasP id bareTypeP -paliasP = rtAliasP stringSymbol predP - -rtAliasP f bodyP - = do pos <- getPosition - name <- upperIdP - spaces - args <- sepBy aliasIdP spaces - whiteSpace >> reservedOp "=" >> whiteSpace - body <- bodyP - let (tArgs, vArgs) = partition (isLower . head) args - return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos - -aliasIdP :: Parser String -aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head) - -measureP :: Parser (Measure.Measure BareType Symbol) -measureP - = do (x, ty) <- tyBindP - whiteSpace - eqns <- grabs $ measureDefP $ (rawBodyP <|> tyBodyP ty) - return $ Measure.mkM x ty eqns - -rawBodyP - = braces $ do - v <- symbolP - reserved "|" - p <- predP - return $ Measure.R v p - --- tyBodyP :: BareType -> Parser Measure.Body -tyBodyP ty - = case outTy ty of - Just bt | isPropBareType bt -> Measure.P <$> predP - _ -> Measure.E <$> exprP - where outTy (RAllT _ t) = outTy t - outTy (RAllP _ t) = outTy t - outTy (RFun _ _ t _) = Just t - outTy _ = Nothing - -binderP :: Parser Symbol -binderP = try $ stringSymbol <$> idP badc - <|> pwr <$> parens (idP bad) - where - idP p = many1 (satisfy (not . p)) - badc c = (c == ':') || (c == ',') || bad c - bad c = isSpace c || c `elem` "(,)" - pwr s = stringSymbol $ "(" ++ s ++ ")" - -grabs p = try (liftM2 (:) p (grabs p)) - <|> return [] - -measureDefP :: Parser Measure.Body -> Parser (Measure.Def Symbol) -measureDefP bodyP - = do mname <- locParserP symbolP - (c, xs) <- {- ORIGINAL parens $ -} measurePatP - whiteSpace >> reservedOp "=" >> whiteSpace - body <- bodyP - whiteSpace - let xs' = (stringSymbol . val) <$> xs - return $ Measure.Def mname (stringSymbol c) xs' body - --- ORIGINAL --- measurePatP :: Parser (String, [LocString]) --- measurePatP --- = try (liftM2 (,) upperIdP (sepBy locLowerIdP whiteSpace)) --- <|> try (liftM3 (\x c y -> (c, [x,y])) locLowerIdP colon locLowerIdP) --- <|> (brackets whiteSpace >> return ("[]",[])) - -measurePatP :: Parser (String, [LocString]) -measurePatP - = try tupPatP - <|> try (parens conPatP) - <|> try (parens consPatP) - <|> (parens nilPatP) - -tupPatP = mkTupPat <$> (parens $ sepBy locLowerIdP comma) -conPatP = (,) <$> dataConNameP <*> sepBy locLowerIdP whiteSpace -consPatP = mkConsPat <$> locLowerIdP <*> colon <*> locLowerIdP -nilPatP = mkNilPat <$> brackets whiteSpace - -mkTupPat zs = (tupDataCon (length zs), zs) -mkNilPat _ = ("[]", [] ) -mkConsPat x c y = (":" , [x, y]) - -tupDataCon n = "(" ++ replicate (n - 1) ',' ++ ")" -locLowerIdP = locParserP lowerIdP - -{- len (Cons x1 x2 ...) = e -} - - -------------------------------------------------------------------------------- ---------------------------------- Predicates ---------------------------------- -------------------------------------------------------------------------------- - -dataConFieldsP - = (braces $ sepBy predTypeDDP comma) - <|> (sepBy (parens predTypeDDP) spaces) - -predTypeDDP - = liftM2 (,) bbindP bareTypeP - -dataConP - = do x <- dataConNameP - spaces - xts <- dataConFieldsP - return (x, xts) - --- dataConNameP = symbolString <$> binderP -- upperIdP -dataConNameP - = try upperIdP - <|> pwr <$> parens (idP bad) - where - idP p = many1 (satisfy (not . p)) - bad c = isSpace c || c `elem` "(,)" - pwr s = "(" ++ s ++ ")" - -dataSizeP - = (brackets $ (Just . mkFun) <$> lowerIdP) - <|> return Nothing - where mkFun s = \x -> EApp (stringSymbol s) [EVar x] - -dataDeclP - = do pos <- getPosition - x <- upperIdP - spaces - fsize <- dataSizeP - spaces - ts <- sepBy tyVarIdP spaces - ps <- predVarDefsP - whiteSpace >> reservedOp "=" >> whiteSpace - dcs <- sepBy dataConP (reserved "|") - whiteSpace - -- spaces - -- reservedOp "--" - return $ D x ts ps dcs pos fsize - ---------------------------------------------------------------------- ------------- Interacting with Fixpoint ------------------------------ ---------------------------------------------------------------------- - -grabUpto p - = try (lookAhead p >>= return . Just) - <|> try (eof >> return Nothing) - <|> (anyChar >> grabUpto p) - -betweenMany leftP rightP p - = do z <- grabUpto leftP - case z of - Just _ -> liftM2 (:) (between leftP rightP p) (betweenMany leftP rightP p) - Nothing -> return [] - --- specWrap = between (string "{-@" >> spaces) (spaces >> string "@-}") -specWraps = betweenMany (string "{-@" >> spaces) (spaces >> string "@-}") - ----------------------------------------------------------------------------------------- ------------------------- Bundling Parsers into a Typeclass ----------------------------- ----------------------------------------------------------------------------------------- - -instance Inputable BareType where - rr' = doParse' bareTypeP - -instance Inputable (Measure.Measure BareType Symbol) where - rr' = doParse' measureP - - -{- ---------------------------------------------------------------- ---------------------------- Testing --------------------------- ---------------------------------------------------------------- - -sa = "0" -sb = "x" -sc = "(x0 + y0 + z0) " -sd = "(x+ y * 1)" -se = "_|_ " -sf = "(1 + x + _|_)" -sg = "f(x,y,z)" -sh = "(f((x+1), (y * a * b - 1), _|_))" -si = "(2 + f((x+1), (y * a * b - 1), _|_))" - -s0 = "true" -s1 = "false" -s2 = "v > 0" -s3 = "(0 < v && v < 100)" -s4 = "(x < v && v < y+10 && v < z)" -s6 = "[(v > 0)]" -s6' = "x" -s7' = "(x <=> y)" -s8' = "(x <=> a = b)" -s9' = "(x <=> (a <= b && b < c))" - -s7 = "{ v: Int | [(v > 0)] }" -s8 = "x:{ v: Int | v > 0 } -> {v : Int | v >= x}" -s9 = "v = x+y" -s10 = "{v: Int | v = x + y}" - -s11 = "x:{v:Int | true } -> {v:Int | true }" -s12 = "y : {v:Int | true } -> {v:Int | v = x }" -s13 = "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" -s14 = "x:{v:a | true} -> y:{v:b | true } -> {v:a | (x < v && v < y) }" -s15 = "x:Int -> Bool" -s16 = "x:Int -> y:Int -> {v:Int | v = x + y}" -s17 = "a" -s18 = "x:a -> Bool" -s20 = "forall a . x:Int -> Bool" - -s21 = "x:{v : GHC.Prim.Int# | true } -> {v : Int | true }" - -r0 = (rr s0) :: Pred -r0' = (rr s0) :: [Refa] -r1 = (rr s1) :: [Refa] - - -e1, e2 :: Expr -e1 = rr "(k_1 + k_2)" -e2 = rr "k_1" - -o1, o2, o3 :: FixResult Integer -o1 = rr "SAT " -o2 = rr "UNSAT [1, 2, 9,10]" -o3 = rr "UNSAT []" - --- sol1 = doParse solution1P "solution: k_5 := [0 <= VV_int]" --- sol2 = doParse solution1P "solution: k_4 := [(0 <= VV_int)]" - -b0, b1, b2, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13 :: BareType -b0 = rr "Int" -b1 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" -b2 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y}" -b4 = rr "forall a . x : a -> Bool" -b5 = rr "Int -> Int -> Int" -b6 = rr "(Int -> Int) -> Int" -b7 = rr "({v: Int | v > 10} -> Int) -> Int" -b8 = rr "(x:Int -> {v: Int | v > x}) -> {v: Int | v > 10}" -b9 = rr "x:Int -> {v: Int | v > x} -> {v: Int | v > 10}" -b10 = rr "[Int]" -b11 = rr "x:[Int] -> {v: Int | v > 10}" -b12 = rr "[Int] -> String" -b13 = rr "x:(Int, [Bool]) -> [(String, String)]" - --- b3 :: BareType --- b3 = rr "x:Int -> y:Int -> {v:Bool | ((v is True) <=> x = y)}" - -m1 = ["len :: [a] -> Int", "len (Nil) = 0", "len (Cons x xs) = 1 + len(xs)"] -m2 = ["tog :: LL a -> Int", "tog (Nil) = 100", "tog (Cons y ys) = 200"] - -me1, me2 :: Measure.Measure BareType Symbol -me1 = (rr $ intercalate "\n" m1) -me2 = (rr $ intercalate "\n" m2) --} diff --git a/Language/Haskell/Liquid/PredType.hs b/Language/Haskell/Liquid/PredType.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/PredType.hs +++ /dev/null @@ -1,431 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances, TupleSections #-} -module Language.Haskell.Liquid.PredType ( - PrType - , TyConP (..), DataConP (..) - , dataConTy, dataConPSpecType, makeTyConInfo - , unify, replacePreds, exprType, predType - , replacePredsWithRefs, pVartoRConc, toPredType - , substParg - , pApp - , wiredSortedSyms - ) where - --- import PprCore (pprCoreExpr) -import Id (idType) -import CoreSyn hiding (collectArgs) -import Type -import TypeRep -import qualified TyCon as TC -import Literal -import Coercion (coercionType, coercionKind) -import Pair (pSnd) -import FastString (sLit) -import qualified Outputable as O -import Text.PrettyPrint.HughesPJ -import DataCon - -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.List (partition, foldl') -import Data.Monoid (mempty) - -import Language.Fixpoint.Misc -import Language.Fixpoint.Types hiding (Predicate, Expr) -import qualified Language.Fixpoint.Types as F -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType hiding (generalize) -import Language.Haskell.Liquid.GhcMisc - -import Control.Applicative ((<$>)) -import Control.Monad.State - -makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList - -mkRTyCon :: TC.TyCon -> TyConP -> RTyCon -mkRTyCon tc (TyConP αs' ps cv conv size) = RTyCon tc pvs' (mkTyConInfo tc cv conv size) - where τs = [rVar α :: RSort | α <- TC.tyConTyVars tc] - pvs' = subts (zip αs' τs) <$> ps - -dataConPSpecType :: DataCon -> DataConP -> SpecType -dataConPSpecType dc (DataConP vs ps yts rt) = mkArrow vs ps (reverse yts') rt' - where (xs, ts) = unzip yts - ys = mkDSym <$> xs - su = F.mkSubst $ [(x, F.EVar y) | (x, y) <- zip xs ys] - yts' = zip ys (subst su <$> ts) - rt' = subst su rt - mkDSym = stringSymbol . (++ ('_':(showPpr dc))) . show --- where t1 = foldl' (\t2 (x, t1) -> rFun x t1 t2) rt yts --- t2 = foldr RAllP t1 ps --- t3 = foldr RAllT t2 vs - - -instance PPrint TyConP where - pprint (TyConP vs ps _ _ _) - = (parens $ hsep (punctuate comma (map pprint vs))) <+> - (parens $ hsep (punctuate comma (map pprint ps))) - -instance Show TyConP where - show = showpp -- showSDoc . ppr - -instance PPrint DataConP where - pprint (DataConP vs ps yts t) - = (parens $ hsep (punctuate comma (map pprint vs))) <+> - (parens $ hsep (punctuate comma (map pprint ps))) <+> - (parens $ hsep (punctuate comma (map pprint yts))) <+> - pprint t - -instance Show DataConP where - show = showpp - -dataConTy m (TyVarTy v) - = M.lookupDefault (rVar v) (RTV v) m -dataConTy m (FunTy t1 t2) - = rFun dummySymbol (dataConTy m t1) (dataConTy m t2) -dataConTy m (ForAllTy α t) - = RAllT (rTyVar α) (dataConTy m t) -dataConTy _ t - | Just t' <- ofPredTree (classifyPredType t) - = t' -dataConTy m (TyConApp c ts) - = rApp c (dataConTy m <$> ts) [] mempty -dataConTy _ _ - = error "ofTypePAppTy" - ---------------------------------------------------------------------------- --------------- Interfacing Between Predicates and Refinements ------------- ---------------------------------------------------------------------------- - ---------------------------------------------------------------------------- ---------------Interfacing: Unify PrType with SpecType --------------------- ---------------------------------------------------------------------------- - -unify :: Maybe PrType -> SpecType -> SpecType -unify (Just pt) rt = evalState (unifyS rt pt) S.empty -unify _ t = t - ---------------------------------------------------------------------------- -unifyS :: SpecType -> PrType -> State (S.HashSet UsedPVar) SpecType ---------------------------------------------------------------------------- - -unifyS (RAllP p t) pt - = do t' <- unifyS t pt - s <- get - put $ S.delete (uPVar p) s - if (uPVar p `S.member` s) then return $ RAllP p t' else return t' - -unifyS t (RAllP p pt) - = do t' <- unifyS t pt - s <- get - put $ S.delete (uPVar p) s - if (uPVar p `S.member` s) then return $ RAllP p t' else return t' - -unifyS (RAllT (v@(RTV α)) t) (RAllT v' pt) - = do t' <- unifyS t $ subsTyVar_meet (v', (rVar α) :: RSort, RVar v mempty) pt - return $ RAllT v t' - -unifyS (RFun x rt1 rt2 _) (RFun x' pt1 pt2 _) - = do t1' <- unifyS rt1 pt1 - t2' <- unifyS rt2 (substParg (x', EVar x) pt2) - return $ rFun x t1' t2' - -unifyS (RAppTy rt1 rt2 _) (RAppTy pt1 pt2 _) - = do t1' <- unifyS rt1 pt1 - t2' <- unifyS rt2 pt2 - return $ rAppTy t1' t2' - -unifyS t@(RCls _ _) (RCls _ _) - = return t - -unifyS (RVar v a) (RVar _ p) - = do modify $ \s -> s `S.union` (S.fromList $ pvars p) -- (filter (/= PdTrue) [p])) - return $ RVar v $ bUnify a p - -unifyS (RApp c ts rs r) (RApp _ pts ps p) - = do modify $ \s -> s `S.union` fm - ts' <- zipWithM unifyS ts pts - return $ RApp c ts' rs' (bUnify r p) - where fm = S.fromList $ concatMap pvars (fp:fps) - fp : fps = p : (getR <$> ps) - rs' = zipWithZero unifyRef (RMono [] top {- trueReft -}) mempty rs fps - getR (RMono _ r) = r - getR (RPoly _ _) = top - -unifyS (RAllE x tx t) (RAllE x' tx' t') | x == x' - = liftM2 (RAllE x) (unifyS tx tx') (unifyS t t') - -unifyS (REx x tx t) (REx x' tx' t') | x == x' - = liftM2 (REx x) (unifyS tx tx') (unifyS t t') - -unifyS t (REx x' tx' t') - = liftM (REx x' (U top <$> tx')) (unifyS t t') - -unifyS t@(RVar v a) (RAllE x' tx' t') - = liftM (RAllE x' (U top <$> tx')) (unifyS t t') - -unifyS t1 t2 - = error ("unifyS" ++ show t1 ++ " with " ++ show t2) - -bUnify a (Pr pvs) = foldl' meet a $ pToReft <$> pvs - -unifyRef (RMono s a) (Pr pvs) = RMono s $ foldl' meet a $ pToReft <$> pvs -unifyRef (RPoly s a) (Pr pvs) = RPoly s $ foldl' strengthen a $ pToReft <$> pvs - -zipWithZero _ _ _ [] [] = [] -zipWithZero f xz yz [] (y:ys) = (f xz y):(zipWithZero f xz yz [] ys) -zipWithZero f xz yz (x:xs) [] = (f x yz):(zipWithZero f xz yz xs []) -zipWithZero f xz yz (x:xs) (y:ys) = (f x y) :(zipWithZero f xz yz xs ys) - --- pToReft p = Reft (vv, [RPvar p]) -pToReft = U top . pdVar - ----------------------------------------------------------------------------- ------ Interface: Replace Predicate With Uninterprented Function Symbol ----- ----------------------------------------------------------------------------- - -replacePredsWithRefs (p, r) (U (Reft(v, rs)) (Pr ps)) - = U (Reft (v, rs ++ rs')) (Pr ps2) - where rs' = r . (v,) . pargs <$> ps1 - (ps1, ps2) = partition (==p) ps - freeSymbols = snd3 <$> filter (\(_, x, y) -> EVar x == y) pargs1 - pargs1 = concatMap pargs ps1 - -pVartoRConc p (v, args) - = RConc $ pApp (pname p) $ EVar v:(thd3 <$> args) - -toPredType (PV _ ptype args) = rpredType (ty:tys) - where ty = uRTypeGen ptype - tys = uRTypeGen . fst3 <$> args - - ----------------------------------------------------------------------------- ----------- Interface: Replace Predicate With Type ------------------------- ----------------------------------------------------------------------------- - --- | This is the main function used to substitute an (abstract) predicate --- with a concrete Ref, of a compound (`RPoly`) type. The substitution is --- invoked to obtain the `SpecType` resulting at /predicate application/ --- sites in 'Language.Haskell.Liquid.Constraint'. --- The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`. --- That is, there are no further `PVar` in the target. - -------------------------------------------------------------------------------- - -replacePreds :: String -> SpecType -> [(RPVar, Ref RSort RReft SpecType)] -> SpecType -replacePreds msg = foldl' go - where go z (π, t@(RPoly _ _)) = substPred msg (π, t) z - go _ (_, RMono _ _) = error "replacePreds on RMono" -- replacePVarReft (π, r) <$> z - - --- TODO: replace `replacePreds` with --- instance SubsTy RPVar (Ref RReft SpecType) SpecType where --- subt (pv, r) t = replacePreds "replacePred" t (pv, r) - --- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType --- replacePreds msg = foldl' go --- where go z (π, RPoly t) = substPred msg (π, t) z --- go z (π, RMono r) = replacePVarReft (π, r) <$> z - -------------------------------------------------------------------------------- -substPred :: String -> (RPVar, Ref RSort RReft SpecType) -> SpecType -> SpecType -------------------------------------------------------------------------------- - -substPred _ (π, RPoly ss (RVar a1 r1)) t@(RVar a2 r2) - | isPredInReft && a1 == a2 = RVar a1 $ meetListWithPSubs πs ss r1 r2' - | isPredInReft = errorstar ("substPred RVar Var Mismatch" ++ show (a1, a2)) - | otherwise = t - where (r2', πs) = splitRPvar π r2 - isPredInReft = not $ null πs - -substPred msg su@(π, _ ) (RApp c ts rs r) - | null πs = t' - | otherwise = substRCon msg su t' πs r2' - where t' = RApp c (substPred msg su <$> ts) (substPredP su <$> rs) r - (r2', πs) = splitRPvar π r - -substPred msg (p, tp) (RAllP (q@(PV _ _ _)) t) - | p /= q = RAllP q $ substPred msg (p, tp) t - | otherwise = RAllP q t - -substPred msg su (RAllT a t) = RAllT a (substPred msg su t) - -substPred msg su@(π,_ ) (RFun x t t' r) - | null πs = RFun x (substPred msg su t) (substPred msg su t') r - | otherwise = {-meetListWithPSubs πs πt -}(RFun x t t' r') - where (r', πs) = splitRPvar π r - -substPred msg pt (RCls c ts) = RCls c (substPred msg pt <$> ts) - -substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t') -substPred msg su (REx x t t') = REx x (substPred msg su t) (substPred msg su t') - -substPred _ _ t = t - --- | Requires: @not $ null πs@ --- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType - -substRCon msg (_, RPoly ss (RApp c1 ts1 rs1 r1)) (RApp c2 ts2 rs2 _) πs r2' - | rTyCon c1 == rTyCon c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2' - where ts = safeZipWith (msg ++ ": substRCon") strSub ts1 ts2 - rs = safeZipWith (msg ++ ": substRcon2") strSubR rs1 rs2 - strSub r1 r2 = meetListWithPSubs πs ss r1 r2 - strSubR r1 r2 = meetListWithPSubsRef πs ss r1 r2 - -substRCon msg su t _ _ = errorstar $ msg ++ " substRCon " ++ showpp (su, t) - -substPredP su@(p, RPoly ss tt) (RPoly s t) - = RPoly ss' $ substPred "substPredP" su t - where ss' = if isPredInType p t then (ss ++ s) else s - -substPredP _ (RMono _ _) - = error $ "RMono found in substPredP" - -splitRPvar pv (U x (Pr pvs)) = (U x (Pr pvs'), epvs) - where (epvs, pvs') = partition (uPVar pv ==) pvs - - -isPredInType p (RVar _ r) - = isPredInURef p r -isPredInType p (RFun _ t1 t2 r) - = isPredInURef p r || isPredInType p t1 || isPredInType p t2 -isPredInType p (RAllT _ t) - = isPredInType p t -isPredInType p (RAllP p' t) - = not (p == p') && isPredInType p t -isPredInType p (RApp _ ts _ r) - = isPredInURef p r || any (isPredInType p) ts -isPredInType p (RCls _ ts) - = any (isPredInType p) ts -isPredInType p (RAllE _ t1 t2) - = isPredInType p t1 || isPredInType p t2 -isPredInType p (RAppTy t1 t2 r) - = isPredInURef p r || isPredInType p t1 || isPredInType p t2 -isPredInType _ (RExprArg _) - = False -isPredInType _ (ROth _) - = False - -isPredInURef p (U _ (Pr ps)) = any (uPVar p ==) ps - - -meetListWithPSubs πs ss r1 r2 = foldl' (meetListWithPSub ss r1) r2 πs -meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs - --- meetListWithPSub :: (Reftable r, PPrint t) => [(Symbol, RSort)]-> r -> r -> PVar t -> r -meetListWithPSub ss r1 r2 π - | all (\(_, x, EVar y) -> x == y) (pargs π) - = r2 `meet` r1 - | all (\(_, x, EVar y) -> x /= y) (pargs π) - = r2 `meet` (subst su r1) - | otherwise - = errorstar $ "PredType.meetListWithPSub partial application to " ++ showpp π - where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)] - -meetListWithPSubRef ss (RPoly s1 r1) (RPoly s2 r2) π - | all (\(_, x, EVar y) -> x == y) (pargs π) - = RPoly s1 $ r2 `meet` r1 - | all (\(_, x, EVar y) -> x /= y) (pargs π) - = RPoly s2 $ r2 `meet` (subst su r1) - | otherwise - = errorstar $ "PredType.meetListWithPSubRef partial application to " ++ showpp π - where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> s1) (pargs π)] - - ----------------------------------------------------------------------------- ----------- Interface: Modified CoreSyn.exprType due to predApp ------------- ----------------------------------------------------------------------------- - -predName :: String -predName = "Pred" - -predType :: Type -predType = TyVarTy $ stringTyVar predName - -rpredType :: Reftable r => [RRType r] -> RRType r -rpredType ts = RApp tyc ts [] top - where - tyc = RTyCon (stringTyCon 'x' 42 predName) [] defaultTyConInfo - -defaultTyConInfo = TyConInfo [] [] [] [] Nothing - ----------------------------------------------------------------------------- -exprType :: CoreExpr -> Type ----------------------------------------------------------------------------- - -exprType (App e1 (Var v)) | eqType (idType v) predType = exprType e1 -exprType (Var var) = idType var -exprType (Lit lit) = literalType lit -exprType (Coercion co) = coercionType co -exprType (Let _ body) = exprType body -exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = pSnd (coercionKind co) -exprType (Tick _ e) = exprType e -exprType (Lam binder expr) = mkPiType binder (exprType expr) -exprType e@(App _ _) - = case collectArgs e of - (fun, args) -> applyTypeToArgs e (exprType fun) args -exprType _ = error "PredType : exprType" - --- | Takes a nested application expression and returns the the function --- being applied and the arguments to which it is applied -collectArgs :: Expr b -> (Expr b, [Arg b]) -collectArgs expr - = go expr [] - where - go (App f (Var v)) as | eqType (idType v) predType = go f as - go (App f a) as = go f (a:as) - go e as = (e, as) - - --- | A more efficient version of 'applyTypeToArg' when we have several arguments. --- The first argument is just for debugging, and gives some context --- RJ: This function is UGLY. Two nested levels of where is a BAD idea. --- Please fix. - -applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type - -applyTypeToArgs _ op_ty [] = op_ty - -applyTypeToArgs e op_ty (Type ty : args) - = -- Accumulate type arguments so we can instantiate all at once - go [ty] args - where - go rev_tys (Type ty : args) = go (ty:rev_tys) args - go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args - where - op_ty' = applyTysD msg op_ty (reverse rev_tys) - msg = O.text ("MYapplyTypeToArgs: " ++ panic_msg e op_ty) - - -applyTypeToArgs e op_ty (_ : args) - = case (splitFunTy_maybe op_ty) of - Just (_, res_ty) -> applyTypeToArgs e res_ty args - Nothing -> errorstar $ "MYapplyTypeToArgs" ++ panic_msg e op_ty - -panic_msg :: CoreExpr -> Type -> String -panic_msg e op_ty = showPpr e ++ " :: " ++ showPpr op_ty - -substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate -substParg (x, y) = fmap fp -- RJ: UNIFY: BUG mapTy fxy - where fxy s = if (s == EVar x) then y else s - fp = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv }) - -------------------------------------------------------------------------------- ------------------------------ Predicate Application -------------------------- -------------------------------------------------------------------------------- - -pappArity = 2 - -pappSym n = S $ "papp" ++ show n - -pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [bSort] - where ptycon = FApp predFTyCon $ FVar <$> [0..n-1] - args = FVar <$> [n..(2*n-1)] - bSort = FApp boolFTyCon [] - -wiredSortedSyms = [(pappSym n, pappSort n) | n <- [1..pappArity]] - -predFTyCon = stringFTycon predName - -pApp :: Symbol -> [F.Expr] -> Pred -pApp p es= PBexp $ EApp (pappSym $ length es) (EVar p:es) - diff --git a/Language/Haskell/Liquid/Predicates.hs b/Language/Haskell/Liquid/Predicates.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Predicates.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction, TypeSynonymInstances, FlexibleInstances, TupleSections, DeriveDataTypeable, BangPatterns #-} -module Language.Haskell.Liquid.Predicates ( - generatePredicates - ) where - - -import Var -import OccName (mkTyVarOcc) -import Name (mkInternalName) -import Unique (initTyVarUnique) -import SrcLoc -import CoreSyn -import qualified DataCon as TC -import IdInfo - -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.Bare -import Language.Haskell.Liquid.GhcInterface -import Language.Haskell.Liquid.PredType hiding (exprType) -import Language.Haskell.Liquid.RefType hiding (generalize) -import Language.Fixpoint.Misc -import qualified Language.Fixpoint.Types as F - -import Control.Applicative ((<$>)) - ----------------------------------------------------------------------- ----- Predicate Environments ------------------------------------------ ----------------------------------------------------------------------- - - -generatePredicates :: GhcInfo -> ([CoreSyn.Bind CoreBndr], F.SEnv PrType) -generatePredicates info = {-trace ("Predicates\n" ++ show γ ++ "PredCBS" ++ show cbs')-} (cbs', nPd) - where -- WHAT?! All the predicate constraint stuff is DEAD CODE?!! - -- γ = fmap removeExtPreds (penv $ evalState act (initPI $ tconsP $ spec info)) - -- act = consAct info - cbs' = addPredApp nPd <$> cbs info - nPd = getNeedPd $ spec info - -getNeedPd spec - = F.fromListSEnv bs - where dcs = concatMap mkDataConIdsTy [(x, dataConPtoPredTy x y) | (x, y) <- dconsP spec] - assms = (mapSnd (mapReft ur_pred . val)) <$> tySigs spec - bs = mapFst varSymbol <$> (dcs ++ assms) - -dataConPtoPredTy :: TC.DataCon -> DataConP -> PrType -dataConPtoPredTy dc = fmap ur_pred . (dataConPSpecType dc) - - - -addPredApp γ (NonRec b e) = NonRec b $ thd3 $ pExpr γ e -addPredApp γ (Rec ls) = Rec $ zip xs es' - where es' = (thd3. pExpr γ) <$> es - (xs, es) = unzip ls - -pExpr γ e - = if (a == 0 && p /= 0) - then (0, 0, foldl App e' ps) - else (0, p, e') - where (a, p, e') = pExprN γ e - ps = (\n -> stringArg ("p" ++ show n)) <$> [1 .. p] - -pExprN γ (App e1 e2) = - let (_, _, e2') = pExprN γ e2 in - if (a1 == 0) - then (0, 0, (App (foldl App e1' ps) e2')) - else (a1-1, p1, (App e1' e2')) - where ps = (\n -> stringArg ("p" ++ show n)) <$> [1 .. p1] - (a1, p1, e1') = pExprN γ e1 - -pExprN γ (Lam x e) = (0, 0, Lam x e') - where (_, _, e') = pExpr γ e - -pExprN γ (Var v) | isSpecialId γ v - = (a, p, (Var v)) - where (a, p) = varPredArgs γ v - -pExprN _ (Var v) = (0, 0, Var v) - -pExprN γ (Let (NonRec x1 e1) e) = (0, 0, Let (NonRec x1 e1') e') - where (_, _, e') = pExpr γ e - (_, _, e1') = pExpr γ e1 - -pExprN γ (Let bds e) = (0, 0, Let bds' e') - where (_, _, e') = pExpr γ e - bds' = addPredApp γ bds -pExprN γ (Case e b t es) = (0, 0, Case e' b t (map (pExprNAlt γ ) es)) - where e' = thd3 $ pExpr γ e - -pExprN γ (Tick n e) = (a, p, Tick n e') - where (a, p, e') = pExprN γ e - -pExprN _ e@(Type _) = (0, 0, e) -pExprN _ e@(Lit _) = (0, 0, e) -pExprN _ e = (0, 0, e) - -pExprNAlt γ (x, y, e) = (x, y, e') - where e' = thd3 $ pExpr γ e - -stringArg s = Var $ mkGlobalVar idDet name predType idInfo - where idDet = coVarDetails - name = mkInternalName initTyVarUnique occ noSrcSpan - occ = mkTyVarOcc s - idInfo = vanillaIdInfo - -isSpecialId γ x = pl /= 0 - where (_, pl) = varPredArgs γ x - -varPredArgs γ x = varPredArgs_ (F.lookupSEnv (varSymbol x) γ) -varPredArgs_ Nothing = (0, 0) -varPredArgs_ (Just t) = (length vs, length ps) - where (vs, ps, _) = bkUniv t - diff --git a/Language/Haskell/Liquid/PrettyPrint.hs b/Language/Haskell/Liquid/PrettyPrint.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/PrettyPrint.hs +++ /dev/null @@ -1,204 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} --- | Module with all the printing routines - -module Language.Haskell.Liquid.PrettyPrint ( - - -- * Printing RType - ppr_rtype - - -- * Converting To String - , showpp - - -- * Printing an Orderable List - , pprManyOrdered - ) where - -import ErrUtils (ErrMsg) -import HscTypes (SourceError) -import SrcLoc (SrcSpan) -import GHC (Name) -import TcType (tidyType) -import VarEnv (emptyTidyEnv) -import Language.Haskell.Liquid.GhcMisc -import Text.PrettyPrint.HughesPJ -import Language.Fixpoint.Types hiding (Predicate) -import Language.Fixpoint.Misc -import Language.Haskell.Liquid.Types -import Language.Fixpoint.Names (dropModuleNames, symSepName, funConName, listConName, tupConName, propConName, boolConName) -import TypeRep hiding (maybeParen, pprArrowChain) -import Text.Parsec.Pos (SourcePos) -import Text.Parsec.Error (ParseError) -import Var (Var) -import Control.Applicative ((<$>)) -import Data.Maybe (fromMaybe) -import Data.List (sort) -import Data.Function (on) - -instance PPrint ErrMsg where - pprint = text . show - -instance PPrint SourceError where - pprint = text . show - -instance PPrint ParseError where - pprint = text . show - -instance PPrint Var where - pprint = pprDoc - -instance PPrint Name where - pprint = pprDoc - -instance PPrint Type where - pprint = pprDoc . tidyType emptyTidyEnv - -instance Show Predicate where - show = showpp - - - --- | Printing an Ordered List - ---------------------------------------------------------------- -pprManyOrdered :: (PPrint a, Ord a) => String -> [a] -> [Doc] ---------------------------------------------------------------- -pprManyOrdered msg = map ((text msg <+>) . pprint) . sort -- By (compare `on` pos) - - ---------------------------------------------------------------- --- | Pretty Printing RefType ---------------------------------- ---------------------------------------------------------------- - -ppr_rtype bb p t@(RAllT _ _) - = ppr_forall bb p t -ppr_rtype bb p t@(RAllP _ _) - = ppr_forall bb p t -ppr_rtype _ _ (RVar a r) - = ppTy r $ pprint a -ppr_rtype bb p (RFun x t t' _) - = pprArrowChain p $ ppr_dbind bb FunPrec x t : ppr_fun_tail bb t' -ppr_rtype bb p (RApp c [t] rs r) - | isList c - = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb rs -ppr_rtype bb p (RApp c ts rs r) - | isTuple c - = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb rs - --- BEXPARSER WHY Does this next case kill the parser for BExp? (e.g. LambdaEval.hs) --- ppr_rtype bb p (RApp c [] [] r) --- = ppTy r $ {- parens $ -} ppTycon c - -ppr_rtype bb p (RApp c ts rs r) - = ppTy r $ parens $ ppTycon c <+> ppReftPs bb rs <+> hsep (ppr_rtype bb p <$> ts) - -ppr_rtype _ _ (RCls c ts) - = ppCls c ts -ppr_rtype bb p t@(REx _ _ _) - = ppExists bb p t -ppr_rtype bb p t@(RAllE _ _ _) - = ppAllExpr bb p t -ppr_rtype _ _ (RExprArg e) - = braces $ pprint e -ppr_rtype bb p (RAppTy t t' r) - = ppTy r $ ppr_rtype bb p t <+> ppr_rtype bb p t' -ppr_rtype _ _ (ROth s) - = text $ "???-" ++ s - --- | From GHC: TypeRep --- pprArrowChain p [a,b,c] generates a -> b -> c -pprArrowChain :: Prec -> [Doc] -> Doc -pprArrowChain _ [] = empty -pprArrowChain p (arg:args) = maybeParen p FunPrec $ - sep [arg, sep (map (arrow <+>) args)] - --- | From GHC: TypeRep -maybeParen :: Prec -> Prec -> Doc -> Doc -maybeParen ctxt_prec inner_prec pretty - | ctxt_prec < inner_prec = pretty - | otherwise = parens pretty - - --- ppExists :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc -ppExists bb p t - = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' - where (zs, t') = split [] t - split zs (REx x t t') = split ((x,t):zs) t' - split zs t = (reverse zs, t) - --- ppAllExpr :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc -ppAllExpr bb p t - = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' - where (zs, t') = split [] t - split zs (RAllE x t t') = split ((x,t):zs) t' - split zs t = (reverse zs, t) - -ppReftPs bb rs - | all isTauto rs = empty - | not (ppPs ppEnv) = empty - | otherwise = angleBrackets $ hsep $ punctuate comma $ pprint <$> rs - --- ppr_dbind :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> Symbol -> RType p c tv r -> Doc -ppr_dbind bb p x t - | isNonSymbol x || (x == dummySymbol) - = ppr_rtype bb p t - | otherwise - = pprint x <> colon <> ppr_rtype bb p t - --- ppr_fun_tail :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> RType p c tv r -> [Doc] -ppr_fun_tail bb (RFun b t t' _) - = (ppr_dbind bb FunPrec b t) : (ppr_fun_tail bb t') -ppr_fun_tail bb t - = [ppr_rtype bb TopPrec t] - --- ppr_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc -ppr_forall bb p t - = maybeParen p FunPrec $ sep [ ppr_foralls bb αs πs , ppr_cls cls, ppr_rtype bb TopPrec t' ] - where - (αs, πs, ct') = bkUniv t - (cls, t') = bkClass ct' - - ppr_foralls False _ _ = empty - ppr_foralls _ [] [] = empty - ppr_foralls True αs πs = text "forall" <+> dαs αs <+> dπs bb πs <> dot - ppr_cls [] = empty - ppr_cls cs = (parens $ hsep $ punctuate comma (uncurry ppCls <$> cs)) <+> text "=>" - - dαs αs = sep $ pprint <$> αs - - dπs _ [] = empty - dπs False _ = empty - dπs True πs = angleBrackets $ intersperse comma $ ppr_pvar_def pprint <$> πs - -ppr_pvar_def pprv (PV s t xts) = pprint s <+> dcolon <+> intersperse arrow dargs - where - dargs = [pprv t | (t,_,_) <- xts] ++ [pprv t, text boolConName] - - - -instance PPrint RTyVar where - pprint (RTV α) - | ppTyVar ppEnv = ppr_tyvar α - | otherwise = ppr_tyvar_short α - -ppr_tyvar = text . tvId -ppr_tyvar_short = text . showPpr - -instance (Reftable s, PPrint s, PPrint p, Reftable p, PPrint t) => PPrint (Ref t s (RType a b c p)) where - pprint (RMono ss s) = ppRefArgs (fst <$> ss) <+> pprint s - pprint (RPoly ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe top (stripRTypeBase s)) - -ppRefArgs [] = empty -ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->" - -ppRefSym (S "") = text "_" -ppRefSym s = pprint s - -instance (PPrint r, Reftable r) => PPrint (UReft r) where - pprint (U r p) - | isTauto r = pprint p - | isTauto p = pprint r - | otherwise = pprint p <> text " & " <> pprint r - - diff --git a/Language/Haskell/Liquid/Qualifier.hs b/Language/Haskell/Liquid/Qualifier.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Qualifier.hs +++ /dev/null @@ -1,125 +0,0 @@ -module Language.Haskell.Liquid.Qualifier ( - specificationQualifiers - ) where - -import Language.Haskell.Liquid.Bare -import Language.Haskell.Liquid.RefType -import Language.Haskell.Liquid.GhcInterface -import Language.Haskell.Liquid.PredType -import Language.Haskell.Liquid.Types -import Language.Fixpoint.Types -import Language.Fixpoint.Misc - -import Control.Applicative ((<$>)) -import Data.List (delete, nub) -import Data.Maybe (fromMaybe) -import qualified Data.HashSet as S -import Data.Bifunctor (second) - ------------------------------------------------------------------------------------ -specificationQualifiers :: Int -> GhcInfo -> [Qualifier] ------------------------------------------------------------------------------------ - -specificationQualifiers k info - = [ q | (x, t) <- tySigs $ spec info - , x `S.member` (S.fromList $ defVars info) - , q <- refTypeQuals (tcEmbeds $ spec info) (val t) - , length (q_params q) <= k + 1 - ] - - --- GRAVEYARD: scraping quals from imports kills the system with too much crap --- specificationQualifiers info = {- filter okQual -} qs --- where --- qs = concatMap refTypeQualifiers ts --- refTypeQualifiers = refTypeQuals $ tcEmbeds spc --- ts = val <$> t1s ++ t2s --- t1s = [t | (x, t) <- tySigs spc, x `S.member` definedVars] --- t2s = [] -- [t | (_, t) <- ctor spc ] --- definedVars = S.fromList $ defVars info --- spc = spec info --- --- okQual = not . any isPred . map snd . q_params --- where --- isPred (FApp tc _) = tc == stringFTycon "Pred" --- isPred _ = False - - -refTypeQuals tce t - = quals ++ - [ pAppQual tce p args (v, expr) - | p <- preds - , (s, v, _) <- pargs p - , (args, expr) <- concatMap (expressionsOfSort (rTypeSort tce s)) quals - ] where quals = refTypeQuals' tce t - preds = snd3 $ bkUniv t - -expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2)) | (v, sort) `elem` pars - = [(filter (/=(v, sort)) pars, e2)] -expressionsOfSort _ _ = [] - -pAppQual tce p args (v, expr) - = Q "Auto" freeVars pred - where freeVars = (vv, tyvv):(predv,typred):args - pred = pApp predv $ EVar vv:predArgs - vv = S "v" - predv = S "~P" - tyvv = rTypeSort tce $ ptype p - typred = rTypeSort tce (toPredType p :: RRType ()) - predArgs = mkexpr <$> (snd3 <$> pargs p) - mkexpr x | x == v = expr - | otherwise = EVar x - --- refTypeQuals :: SpecType -> [Qualifier] -refTypeQuals' tce t0 = go emptySEnv t0 - where go γ t@(RVar _ _) = refTopQuals tce t0 γ t - go γ (RAllT _ t) = go γ t - go γ (RAllP _ t) = go γ t - go γ (RFun x t t' _) = (go γ t) ++ (go (insertSEnv x (rTypeSort tce t) γ) t') - go γ t@(RApp c ts rs _) = (refTopQuals tce t0 γ t) ++ concatMap (go (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ)) ts ++ goRefs c (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ) rs - go γ (RAllE x t t') = (go γ t) ++ (go (insertSEnv x (rTypeSort tce t) γ) t') - go γ (REx x t t') = (go γ t) ++ (go (insertSEnv x (rTypeSort tce t) γ) t') - go _ _ = [] - goRefs c γ rs = concat $ zipWith (goRef γ) rs (rTyConPs c) - goRef γ (RPoly s t) _ = go (insertsSEnv γ s) t - goRef _ (RMono _ _) _ = [] - insertsSEnv = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ) - -refTopQuals tce t0 γ t - = [ mkQual t0 γ v so pa | let (RR so (Reft (v, ras))) = rTypeSortedReft tce t - , RConc p <- ras - , pa <- atoms p - ] ++ - [ mkPQual tce t0 γ s e | let (U _ (Pr ps)) = fromMaybe (msg t) $ stripRTypeBase t - , p <- (findPVar (snd3 (bkUniv t0))) <$> ps - , (s, _, e) <- pargs p - ] where msg t = errorstar $ "Qualifier.refTopQuals: no typebase" ++ showpp t - -mkPQual tce t0 γ t e = mkQual t0 γ' v so pa - where v = S "vv" - so = rTypeSort tce t - γ' = insertSEnv v so γ - pa = PAtom Eq (EVar v) e - -mkQual t0 γ v so p = Q "Auto" ((v, so) : yts) p' - where yts = [(y, lookupSort t0 x γ) | (x, y) <- xys ] - p' = subst (mkSubst (second EVar <$> xys)) p - xys = zipWith (\x i -> (x, S ("~A" ++ show i))) xs [0..] - xs = delete v $ orderedFreeVars γ p - -lookupSort t0 x γ = fromMaybe (errorstar msg) $ lookupSEnv x γ - where msg = "Unknown freeVar " ++ show x ++ " in specification " ++ show t0 - -orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms - --- orderedFreeVars :: Pred -> [Symbol] --- orderedFreeVars p = nub $ everything (++) ([] `mkQ` f) p --- where f (EVar x) = [x] --- f _ = [] - - --- atoms' ps = traceShow ("atoms: ps = " ++ showPpr ps) $ atoms ps -atoms (PAnd ps) = concatMap atoms ps -atoms p = [p] - - diff --git a/Language/Haskell/Liquid/RefType.hs b/Language/Haskell/Liquid/RefType.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/RefType.hs +++ /dev/null @@ -1,1051 +0,0 @@ -{-# LANGUAGE IncoherentInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternGuards #-} - --- | Refinement Types. Mostly mirroring the GHC Type definition, but with --- room for refinements of various sorts. - --- TODO: Desperately needs re-organization. -module Language.Haskell.Liquid.RefType ( - - -- * Functions for lifting Reft-values to Spec-values - uTop, uReft, uRType, uRType', uRTypeGen, uPVar - - -- * Functions for decreasing arguments - , isDecreasing, makeDecrType - - -- * Functions for manipulating `Predicate`s - , pdVar - , findPVar - , freeTyVars, tyClasses, tyConName - - -- TODO: categorize these! - , ofType, ofPredTree, toType - , rTyVar, rVar, rApp - , expandRApp, appRTyCon - , typeSort, typeUniqueSymbol - , strengthen - , generalize, normalizePds - , subts, subvPredicate, subvUReft - , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet - , rTypeSortedReft, rTypeSort - , varSymbol, dataConSymbol, dataConMsReft, dataConReft - , literalFRefType, literalFReft, literalConst - , classBinds - - - , mkDataConIdsTy - , mkTyConInfo - ) where - -import Var -import Literal -import GHC -import DataCon -import PrelInfo (isNumericClass) -import qualified TyCon as TC -import TypeRep hiding (maybeParen, pprArrowChain) -import Type (splitFunTys, expandTypeSynonyms) -import Type (isPredTy, substTyWith, classifyPredType, PredTree(..), predTreePredType) -import TysWiredIn (listTyCon, intDataCon, trueDataCon, falseDataCon) - -import Data.Monoid hiding ((<>)) -import Data.Maybe (fromMaybe, isJust) -import Data.Hashable -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.List as L -import Data.Function (on) -import Control.Applicative hiding (empty) -import Control.DeepSeq -import Control.Monad (liftM, liftM2, liftM3) -import Control.Exception (Exception (..)) -import qualified Data.Foldable as Fold -import Text.Printf -import Text.PrettyPrint.HughesPJ -import Text.Parsec.Pos (SourcePos) - -import Language.Haskell.Liquid.PrettyPrint -import Language.Fixpoint.Types hiding (Predicate) -import Language.Haskell.Liquid.Types hiding (DataConP (..)) - -import Language.Fixpoint.Misc -import Language.Haskell.Liquid.GhcMisc (pprDoc, sDocDoc, typeUniqueString, tracePpr, tvId, getDataConVarUnique, showSDoc, showPpr, showSDocDump) -import Language.Fixpoint.Names (dropModuleNames, symSepName, funConName, listConName, tupConName, propConName, boolConName) -import Data.List (sort, isSuffixOf, foldl') - -pdVar v = Pr [uPVar v] - -findPVar :: [PVar (RType p c tv ())] -> UsedPVar -> PVar (RType p c tv ()) -findPVar ps p - = PV name ty $ zipWith (\(_, _, e) (t, s, _) -> (t, s, e))(pargs p) args - where PV name ty args = fromMaybe (msg p) $ L.find ((==(pname p)) . pname) ps - msg p = errorstar $ "RefType.findPVar" ++ showpp p ++ "not found" - --- | Various functions for converting vanilla `Reft` to `Spec` - -uRType :: RType p c tv a -> RType p c tv (UReft a) -uRType = fmap uTop - -uRType' :: RType p c tv (UReft a) -> RType p c tv a -uRType' = fmap ur_reft - -uRTypeGen :: Reftable b => RType p c tv a -> RType p c tv b -uRTypeGen = fmap (\_ -> top) - -uPVar :: PVar t -> UsedPVar -uPVar = fmap (const ()) - -uReft :: (Symbol, [Refa]) -> UReft Reft -uReft = uTop . Reft - -uTop :: r -> UReft r -uTop r = U r top - --------------------------------------------------------------------- --------------- (Class) Predicates for Valid Refinement Types ------- --------------------------------------------------------------------- - --- Monoid Instances --------------------------------------------------------- - - -instance ( SubsTy tv (RType p c tv ()) (RType p c tv ()) - , SubsTy tv (RType p c tv ()) c - , RefTypable p c tv () - , RefTypable p c tv r - , PPrint (RType p c tv r) - ) - => Monoid (RType p c tv r) where - mempty = error "mempty RefType" - mappend = strengthenRefType - --- MOVE TO TYPES -instance ( SubsTy tv (RType p c tv ()) (RType p c tv ()) - , SubsTy tv (RType p c tv ()) c - , Reftable r - , RefTypable p c tv () - , RefTypable p c tv (UReft r)) - => Monoid (Ref (RType p c tv ()) r (RType p c tv (UReft r))) where - mempty = RMono [] mempty - mappend (RMono s1 r1) (RMono s2 r2) = RMono (s1 ++ s2) $ r1 `meet` r2 - mappend (RMono s1 r) (RPoly s2 t) = RPoly (s1 ++ s2) $ t `strengthen` (U r top) - mappend (RPoly s1 t) (RMono s2 r) = RPoly (s1 ++ s2) $ t `strengthen` (U r top) - mappend (RPoly s1 t1) (RPoly s2 t2) = RPoly (s1 ++ s2) $ t1 `strengthenRefType` t2 - -instance ( Monoid r, Reftable r - , RefTypable a b c r - , RefTypable a b c () - ) => Monoid (Ref (RType a b c ()) r (RType a b c r)) where - mempty = RMono [] mempty - mappend (RMono s1 r1) (RMono s2 r2) = RMono (s1 ++ s2) $ mappend r1 r2 - mappend (RMono s1 r) (RPoly s2 t) = RPoly (s1 ++ s2) $ t `strengthen` r - mappend (RPoly s1 t) (RMono s2 r) = RPoly (s1 ++ s2) $ t `strengthen` r - mappend (RPoly s1 t1) (RPoly s2 t2) = RPoly (s1 ++ s2) $ t1 `strengthenRefType_` t2 - -instance (Reftable r, RefTypable p c tv r, RefTypable p c tv ()) - => Reftable (Ref (RType p c tv ()) r (RType p c tv r)) where - isTauto (RMono _ r) = isTauto r - isTauto (RPoly _ t) = isTrivial t - ppTy (RMono _ r) d = ppTy r d - ppTy (RPoly _ _) _ = errorstar "RefType: Reftable ppTy in RPoly" - toReft = errorstar "RefType: Reftable toReft" - params = errorstar "RefType: Reftable params for Ref" - bot = errorstar "RefType: Reftable bot for Ref" - - --- Subable Instances ---------------------------------------------- - -instance Subable (Ref RSort Reft RefType) where - syms (RMono ss r) = (fst <$> ss) ++ syms r - syms (RPoly ss t) = (fst <$> ss) ++ syms t - - subst su (RMono ss r) = RMono (mapSnd (subst su) <$> ss) $ subst su r - subst su (RPoly ss r) = RPoly (mapSnd (subst su) <$> ss) $ subst su r - - substf f (RMono ss r) = RMono (mapSnd (substf f) <$> ss) $ substf f r - substf f (RPoly ss r) = RPoly (mapSnd (substf f) <$> ss) $ substf f r - substa f (RMono ss r) = RMono (mapSnd (substa f) <$> ss) $ substa f r - substa f (RPoly ss r) = RPoly (mapSnd (substa f) <$> ss) $ substa f r - --- Reftable Instances ------------------------------------------------------- - -instance (PPrint r, Reftable r) => Reftable (RType Class RTyCon RTyVar r) where - isTauto = isTrivial - ppTy = errorstar "ppTy RPoly Reftable" - toReft = errorstar "toReft on RType" - params = errorstar "params on RType" - bot = errorstar "bot on RType" - --- ppTySReft s r d --- = text "\\" <> hsep (toFix <$> s) <+> text "->" <+> ppTy r d - - - --- MOVE TO TYPES - --- TyConable Instances ------------------------------------------------------- - --- MOVE TO TYPES -instance TyConable RTyCon where - isFun = isFunTyCon . rTyCon - isList = (listTyCon ==) . rTyCon - isTuple = TC.isTupleTyCon . rTyCon - ppTycon = toFix - --- MOVE TO TYPES -instance TyConable String where - isFun = (funConName ==) - isList = (listConName ==) - isTuple = (tupConName ==) - ppTycon = text - - --- RefTypable Instances ------------------------------------------------------- - --- MOVE TO TYPES -instance Fixpoint String where - toFix = text - --- MOVE TO TYPES -instance Fixpoint Class where - toFix = text . showPpr - --- MOVE TO TYPES -instance (Eq p, PPrint p, TyConable c, Reftable r, PPrint r) => RefTypable p c String r where - ppCls = ppClass_String - ppRType = ppr_rtype $ ppPs ppEnv - -- ppBase = undefined - --- MOVE TO TYPES -instance (Reftable r, PPrint r) => RefTypable Class RTyCon RTyVar r where - ppCls = ppClass_ClassPred - ppRType = ppr_rtype $ ppPs ppEnv - -- ppBase = undefined - - --- MOVE TO TYPES -class FreeVar a v where - freeVars :: a -> [v] - --- MOVE TO TYPES -instance FreeVar RTyCon RTyVar where - freeVars = (RTV <$>) . tyConTyVars . rTyCon - --- MOVE TO TYPES -instance FreeVar String String where - freeVars _ = [] - -ppClass_String c _ = pprint c <+> text "..." -ppClass_ClassPred c ts = sDocDoc $ pprClassPred c (toType <$> ts) - --- Eq Instances ------------------------------------------------------ - --- MOVE TO TYPES -instance (RefTypable p c tv ()) => Eq (RType p c tv ()) where - (==) = eqRSort M.empty - -eqRSort m (RAllP _ t) (RAllP _ t') - = eqRSort m t t' -eqRSort m (RAllP _ t) t' - = eqRSort m t t' -eqRSort m (RAllT a t) (RAllT a' t') - | a == a' - = eqRSort m t t' - | otherwise - = eqRSort (M.insert a' a m) t t' -eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _) - = eqRSort m t1 t1' && eqRSort m t2 t2' -eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _) - = eqRSort m t1 t1' && eqRSort m t2 t2' -eqRSort m (RApp c ts _ _) (RApp c' ts' _ _) - = ((c == c') && length ts == length ts' && and (zipWith (eqRSort m) ts ts')) -eqRSort m (RCls c ts) (RCls c' ts') - = (c == c') && length ts == length ts' && and (zipWith (eqRSort m) ts ts') -eqRSort m (RVar a _) (RVar a' _) - = a == (M.lookupDefault a' a' m) -eqRSort _ _ _ - = False - --------------------------------------------------------------------- ---------- Wrappers for GHC Type Elements --------------------------- --------------------------------------------------------------------- - -instance Eq Predicate where - (==) = eqpd - -eqpd (Pr vs) (Pr ws) - = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws'] - where vs' = sort vs - ws' = sort ws - - -instance Eq RTyVar where - RTV α == RTV α' = tvId α == tvId α' - -instance Ord RTyVar where - compare (RTV α) (RTV α') = compare (tvId α) (tvId α') - -instance Hashable RTyVar where - hashWithSalt i (RTV α) = hashWithSalt i α - - -instance Ord RTyCon where - compare x y = compare (rTyCon x) (rTyCon y) - -instance Eq RTyCon where - x == y = (rTyCon x) == (rTyCon y) - -instance Hashable RTyCon where - hashWithSalt i = hashWithSalt i . rTyCon - --------------------------------------------------------------------- ----------------------- Helper Functions ---------------------------- --------------------------------------------------------------------- - -rVar = (`RVar` top) . RTV -rTyVar = RTV - -normalizePds t = addPds ps t' - where (t', ps) = nlzP [] t - -rPred p t = RAllP p t -rApp c = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing)) - - -addPds ps (RAllT v t) = RAllT v $ addPds ps t -addPds ps t = foldl' (flip rPred) t ps - -nlzP ps t@(RVar _ _ ) - = (t, ps) -nlzP ps (RFun b t1 t2 r) - = (RFun b t1' t2' r, ps ++ ps1 ++ ps2) - where (t1', ps1) = nlzP [] t1 - (t2', ps2) = nlzP [] t2 -nlzP ps (RAppTy t1 t2 r) - = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2) - where (t1', ps1) = nlzP [] t1 - (t2', ps2) = nlzP [] t2 -nlzP ps (RAllT v t ) - = (RAllT v t', ps ++ ps') - where (t', ps') = nlzP [] t -nlzP ps t@(RApp _ _ _ _) - = (t, ps) -nlzP ps t@(RCls _ _) - = (t, ps) -nlzP ps (RAllP p t) - = (t', [p] ++ ps ++ ps') - where (t', ps') = nlzP [] t -nlzP ps t@(ROth _) - = (t, ps) -nlzP ps t@(REx _ _ _) - = (t, ps) -nlzP ps t@(RAllE _ _ _) - = (t, ps) -nlzP _ t - = errorstar $ "RefType.nlzP: cannot handle " ++ show t - --- 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 - | otherwise - = errorstar msg - where eqt t1 t2 = {- render -} (toRSort t1) == {- render -} (toRSort t2) - msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" - (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2)) - -unifyShape :: ( RefTypable p c tv r - , FreeVar c tv - , RefTypable p c tv () - , SubsTy tv (RType p c tv ()) (RType p c tv ()) - , SubsTy tv (RType p c tv ()) c) - => RType p c tv r -> RType p c tv r -> Maybe (RType p c tv r) - -unifyShape (RAllT a1 t1) (RAllT a2 t2) - | a1 == a2 = RAllT a1 <$> unifyShape t1 t2 - | otherwise = RAllT a1 <$> unifyShape t1 (sub a2 a1 t2) - where sub a b = let bt = RVar b top in subsTyVar_meet (a, toRSort bt, bt) - -unifyShape t1 t2 - | eqt t1 t2 = Just t1 - | otherwise = Nothing - where eqt t1 t2 = showpp (toRSort t1) == showpp (toRSort t2) - --- strengthenRefType_ :: RefTypable p c tv r =>RType p c tv r -> RType p c tv r -> RType p c tv r -strengthenRefType_ (RAllT a1 t1) (RAllT _ t2) - = RAllT a1 $ strengthenRefType_ t1 t2 - -strengthenRefType_ (RAllP p1 t1) (RAllP _ t2) - = RAllP p1 $ strengthenRefType_ t1 t2 - -strengthenRefType_ (RAppTy t1 t1' r1) (RAppTy t2 t2' r2) - = RAppTy t t' (r1 `meet` r2) - where t = strengthenRefType_ t1 t2 - t' = strengthenRefType_ t1' t2' - -strengthenRefType_ (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) - = RFun x1 t t' (r1 `meet` r2) - where t = strengthenRefType_ t1 t2 - t' = strengthenRefType_ t1' $ subst1 t2' (x2, EVar x1) - -strengthenRefType_ (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2) - = RApp tid ts rs (r1 `meet` r2) - where ts = zipWith strengthenRefType_ t1s t2s - rs = {- tracePpr msg $ -} meets rs1 rs2 - msg = "strengthenRefType_: RApp rs1 = " ++ showpp rs1 ++ " rs2 = " ++ showpp rs2 - - -strengthenRefType_ (RVar v1 r1) (RVar _ r2) - = RVar v1 ({- tracePpr msg $ -} r1 `meet` r2) - where msg = "strengthenRefType_: RVAR r1 = " ++ showpp r1 ++ " r2 = " ++ showpp r2 - -strengthenRefType_ t1 _ - = t1 - -meets [] rs = rs -meets rs [] = rs -meets rs rs' - | length rs == length rs' = zipWith meet rs rs' - | otherwise = errorstar "meets: unbalanced rs" - - -strengthen :: Reftable r => RType p c tv r -> r -> RType p c tv r -strengthen (RApp c ts rs r) r' = RApp c ts rs (r `meet` r') -strengthen (RVar a r) r' = RVar a (r `meet` r') -strengthen (RFun b t1 t2 r) r' = RFun b t1 t2 (r `meet` r') -strengthen (RAppTy t1 t2 r) r' = RAppTy t1 t2 (r `meet` r') -strengthen t _ = t - -expandRApp tce tyi (RApp rc ts rs r) - = RApp rc' ts (appRefts rc' rs) r - where rc' = appRTyCon tce tyi rc ts - -expandRApp _ _ t - = t - -appRTyCon tce tyi rc@(RTyCon c _ _) ts = RTyCon c ps' (rTyConInfo rc'') - where ps' = map (subts (zip (RTV <$> αs) (toRSort <$> ts))) (rTyConPs rc') - rc' = M.lookupDefault rc c tyi - αs = TC.tyConTyVars $ rTyCon rc' - rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc' -isNumeric tce c - = (fromMaybe (stringFTycon $ tyConName (rTyCon c))) - (M.lookup (rTyCon c) tce) == intFTyCon - -addNumSizeFun c - = c {rTyConInfo=(rTyConInfo c){sizeFunction = Just EVar}} - -appRefts rc [] = RPoly [] . ofRSort . ptype <$> (rTyConPs rc) -appRefts rc rs = safeZipWith ("appRefts" ++ showFix rc) toPoly rs (rTyConPs rc) - -toPoly (RPoly ss t) rc - | length (pargs rc) == length ss - = RPoly ss t - | otherwise - = RPoly ([(s, t) | (t, s, _) <- pargs rc]) t -toPoly (RMono ss r) t - = RPoly ss $ (ofRSort $ ptype t) `strengthen` r - -generalize t = mkUnivs (freeTyVars t) [] t - -freeTyVars (RAllP _ t) = freeTyVars t -freeTyVars (RAllT α t) = freeTyVars t L.\\ [α] -freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t' -freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts -freeTyVars (RCls _ ts) = [] -freeTyVars (RVar α _) = [α] -freeTyVars (RAllE _ _ t) = freeTyVars t -freeTyVars (REx _ _ t) = freeTyVars t -freeTyVars (RExprArg _) = [] -freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t' -freeTyVars t = errorstar ("RefType.freeTyVars cannot handle" ++ show t) - ---getTyVars = everything (++) ([] `mkQ` f) --- where f ((RVar α' _) :: SpecType) = [α'] --- f _ = [] - -tyClasses (RAllP _ t) = tyClasses t -tyClasses (RAllT α t) = tyClasses t -tyClasses (RAllE _ _ t) = tyClasses t -tyClasses (REx _ _ t) = tyClasses t -tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t' -tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t' -tyClasses (RApp _ ts _ _) = concatMap tyClasses ts -tyClasses (RCls c ts) = (c, ts) : concatMap tyClasses ts -tyClasses (RVar α _) = [] -tyClasses t = errorstar ("RefType.tyClasses cannot handle" ++ show t) - - - ---getTyClasses = everything (++) ([] `mkQ` f) --- where f ((RCls c ts) :: SpecType) = [(c, ts)] --- f _ = [] - - - ----------------------------------------------------------------- ----------------------- Strictness ------------------------------ ----------------------------------------------------------------- - -instance (NFData a, NFData b, NFData t) => NFData (Ref t a b) where - rnf (RMono s a) = rnf s `seq` rnf a - rnf (RPoly s b) = rnf s `seq` rnf b - -instance (NFData a, NFData b, NFData c, NFData e) => NFData (RType a b c e) where - rnf (RVar α r) = rnf α `seq` rnf r - rnf (RAllT α t) = rnf α `seq` rnf t - rnf (RAllP π t) = rnf π `seq` rnf t - rnf (RFun x t t' r) = rnf x `seq` rnf t `seq` rnf t' `seq` rnf r - rnf (RApp _ ts rs r) = rnf ts `seq` rnf rs `seq` rnf r - rnf (RCls c ts) = c `seq` rnf ts - rnf (RAllE x t t') = rnf x `seq` rnf t `seq` rnf t' - rnf (REx x t t') = rnf x `seq` rnf t `seq` rnf t' - rnf (ROth s) = rnf s - rnf (RExprArg e) = rnf e - rnf (RAppTy t t' r) = rnf t `seq` rnf t' `seq` rnf r - ----------------------------------------------------------------- ------------------- Printing Refinement Types ------------------- ----------------------------------------------------------------- - -instance Show RTyVar where - show = showpp - -instance PPrint (UReft r) => Show (UReft r) where - show = showpp - --- instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a, b, c) where --- toFix (a, b, c) = hsep ([toFix a ,toFix b, toFix c]) - -instance (RefTypable p c tv r) => PPrint (RType p c tv r) where - pprint = ppRType TopPrec - -instance PPrint (RType p c tv r) => Show (RType p c tv r) where - show = showpp - -instance Fixpoint RTyCon where - toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n" - -instance PPrint RTyCon where - pprint = toFix - -instance Show RTyCon where - show = showpp - - ------------------------------------------------------------------------------------------- --- TODO: Rewrite subsTyvars with Traversable ------------------------------------------------------------------------------------------- - -subsTyVars_meet = subsTyVars True -subsTyVars_nomeet = subsTyVars False -subsTyVar_nomeet = subsTyVar False -subsTyVar_meet = subsTyVar True -subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats -subsTyVar meet = subsFree meet S.empty - ---subsFree :: ( Ord tv --- , SubsTy tv ty c --- , SubsTy tv ty r --- , SubsTy tv ty (PVar (RType p c tv ())) --- , RefTypable p c tv r) --- => Bool --- -> S.Set tv --- -> (tv, ty, RType p c tv r) --- -> RType p c tv r --- -> RType p c tv r - -subsFree m s z@(α, τ,_) (RAllP π t) - = RAllP (subt (α, τ) π) (subsFree m s z t) -subsFree m s z (RAllT α t) - = RAllT α $ subsFree m (α `S.insert` s) z t -subsFree m s z@(_, _, _) (RFun x t t' r) - = RFun x (subsFree m s z t) (subsFree m s z t') ({- subt (α, τ) -} r) -subsFree m s z@(α, τ, _) (RApp c ts rs r) - = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) ({- subt z' -} r) - where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters? -subsFree m s z (RCls c ts) - = RCls c (subsFree m s z <$> ts) -subsFree meet s (α', _, t') t@(RVar α r) - | α == α' && not (α `S.member` s) - = if meet then t' `strengthen` {- subt (α', τ') -} r else t' - | otherwise - = t -subsFree m s z (RAllE x t t') - = RAllE x (subsFree m s z t) (subsFree m s z t') -subsFree m s z (REx x t t') - = REx x (subsFree m s z t) (subsFree m s z t') -subsFree m s z@(_, _, _) (RAppTy t t' r) - = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') r -subsFree _ _ _ t@(RExprArg _) - = t -subsFree _ _ _ t@(ROth _) - = t - --- subsFree _ _ _ t --- = errorstar $ "subsFree fails on: " ++ showFix t - -subsFrees m s zs t = foldl' (flip(subsFree m s)) t zs - --- GHC INVARIANT: RApp is Type Application to something other than TYCon -subsFreeRAppTy m s (RApp c ts rs r) t' r' - = mkRApp m s c (ts++[t']) rs r r' -subsFreeRAppTy m s t t' r' - = RAppTy t t' r' - -mkRApp m s c ts rs r r' - | isFun c, [t1, t2] <- ts - = RFun dummySymbol t1 t2 $ refAppTyToFun r' - | otherwise - = subsFrees m s zs $ RApp c ts rs $ r `meet` (refAppTyToApp r') - where zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts] - -refAppTyToFun r - | isTauto r = r - | otherwise = errorstar "RefType.refAppTyToFun" - -refAppTyToApp r - | isTauto r = r - | otherwise = errorstar "RefType.refAppTyToApp" - --- subsFreeRef :: (Ord tv, SubsTy tv ty r, SubsTy tv ty (PVar ty), SubsTy tv ty c, Reftable r, Monoid r, Subable r, RefTypable p c tv (PVar ty) r) => Bool -> S.Set tv -> (tv, ty, RType p c tv (PVar ty) r) -> Ref r (RType p c tv (PVar ty) r) -> Ref r (RType p c tv (PVar ty) r) - -subsFreeRef m s (α', τ', t') (RPoly ss t) - = RPoly (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap (\_ -> top) t') t -subsFreeRef _ _ (α', τ', _) (RMono ss r) - = RMono (mapSnd (subt (α', τ')) <$> ss) $ {- subt (α', τ') -} r - -------------------------------------------------------------------- -------------------- Type Substitutions ---------------------------- -------------------------------------------------------------------- - -subts = flip (foldr subt) - -instance SubsTy tv ty () where - subt _ = id - -instance SubsTy tv ty Reft where - subt _ = id - -instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where - subt su (PV n t xts) = PV n (subt su t) [(subt su t, x, y) | (t,x,y) <- xts] - -instance SubsTy RTyVar RSort RTyCon where - subt z c = c {rTyConPs = subt z <$> rTyConPs c} - --- NOTE: This DOES NOT substitute at the binders -instance SubsTy RTyVar RSort PrType where - subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) - -instance SubsTy RTyVar RSort SpecType where - subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) - -instance SubsTy RTyVar RTyVar SpecType where - subt (α, a) = subt (α, RVar a () :: RSort) - - -instance SubsTy RTyVar RSort RSort where - subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) - --- Here the "String" is a Bare-TyCon. TODO: wrap in newtype -instance SubsTy String BSort String where - subt _ t = t - -instance SubsTy String BSort BSort where - subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) - -instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType p c tv ())) => SubsTy tv ty (Ref (RType p c tv ()) (UReft r) (RType p c tv (UReft r))) where - subt m (RMono ss p) = RMono ((mapSnd (subt m)) <$> ss) $ subt m p - subt m (RPoly ss t) = RPoly ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t - -subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft -subvUReft f (U r p) = U r (subvPredicate f p) - -subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate -subvPredicate f (Pr pvs) = Pr (f <$> pvs) - ---------------------------------------------------------------- - - --- ofType :: Reftable r => Type -> RRType r -ofType = ofType_ . expandTypeSynonyms - -ofType_ (TyVarTy α) - = rVar α -ofType_ (FunTy τ τ') - = rFun dummySymbol (ofType_ τ) (ofType_ τ') -ofType_ (ForAllTy α τ) - = RAllT (rTyVar α) $ ofType_ τ --- ofType_ τ --- | isPredTy τ --- = ofPredTree (classifyPredType τ) -ofType_ τ - | Just t <- ofPredTree (classifyPredType τ) - = t -ofType_ (TyConApp c τs) - | TC.isSynTyCon c - = ofType_ $ substTyWith αs τs τ - | otherwise - = rApp c (ofType_ <$> τs) [] top - where (αs, τ) = TC.synTyConDefn c -ofType_ (AppTy t1 t2) - = RAppTy (ofType_ t1) (ofType t2) top --- ofType_ τ --- = errorstar ("ofType cannot handle: " ++ showPpr τ) - -ofPredTree (ClassPred c τs) - = Just $ RCls c (ofType_ <$> τs) -ofPredTree _ - = Nothing - ----------------------------------------------------------------- -------------------- Converting to Fixpoint --------------------- ----------------------------------------------------------------- - - -varSymbol :: Var -> Symbol -varSymbol v - | us `isSuffixOf` vs = stringSymbol vs - | otherwise = stringSymbol $ vs ++ [symSepName] ++ us - where us = showPpr $ getDataConVarUnique v - vs = showPpr v - -pprShort = dropModuleNames . showPpr - -dataConSymbol :: DataCon -> Symbol -dataConSymbol = varSymbol . dataConWorkId - --- TODO: turn this into a map lookup? -dataConReft :: DataCon -> [Symbol] -> Reft -dataConReft c [] - | c == trueDataCon - = Reft (vv_, [RConc $ eProp vv_]) - | c == falseDataCon - = Reft (vv_, [RConc $ PNot $ eProp vv_]) -dataConReft c [x] - | c == intDataCon - = Reft (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))]) -dataConReft c _ - | not $ isBaseDataCon c - = top -dataConReft c xs - = Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)]) - where dcValue | null xs && null (dataConUnivTyVars c) - = EVar $ dataConSymbol c - | otherwise - = EApp (dataConSymbol c) (EVar <$> xs) - -isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c - -isBaseTy (TyVarTy _) = True -isBaseTy (AppTy t1 t2) = False -isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts -isBaseTy (FunTy _ _) = False -isBaseTy (ForAllTy _ _) = False - --- mkProp x = PBexp (EApp (S propConName) [EVar x]) - -vv_ = vv Nothing - -dataConMsReft ty ys = subst su (rTypeReft t) - where (xs, ts, t) = bkArrow $ thd3 $ bkUniv ty - su = mkSubst [(x, EVar y) | ((x,_), y) <- zip (zip xs ts) ys] - ---------------------------------------------------------------- ----------------------- Embedding RefTypes --------------------- ---------------------------------------------------------------- --- TODO: remove toType, generalize typeSort -toType :: (Reftable r, PPrint r) => RRType r -> Type -toType (RFun _ t t' _) - = FunTy (toType t) (toType t') -toType (RAllT (RTV α) t) - = ForAllTy α (toType t) -toType (RAllP _ t) - = toType t -toType (RVar (RTV α) _) - = TyVarTy α -toType (RApp (RTyCon {rTyCon = c}) ts _ _) - = TyConApp c (toType <$> ts) -toType (RCls c ts) - = predTreePredType $ ClassPred c (toType <$> ts) -toType (RAllE _ _ t) - = toType t -toType (REx _ _ t) - = toType t -toType (RAppTy t t' _) - = AppTy (toType t) (toType t') -toType t@(RExprArg _) - = errorstar $ "RefType.toType cannot handle: " ++ show t -toType t@(ROth _) - = errorstar $ "RefType.toType cannot handle: " ++ show t - - ---------------------------------------------------------------- ------------------------ Typing Literals ----------------------- ---------------------------------------------------------------- - --- makeRTypeBase :: Type -> Reft -> RefType -makeRTypeBase (TyVarTy α) x - = RVar (rTyVar α) x -makeRTypeBase (TyConApp c _) x - = rApp c [] [] x -makeRTypeBase _ _ - = error "RefType : makeRTypeBase" - -literalFRefType tce l - = makeRTypeBase (literalType l) (literalFReft tce l) - -literalFReft tce = maybe top exprReft . snd . literalConst tce - - -- exprReft . snd . literalConst tce - --- | `literalConst` returns `Nothing` for unhandled lits because --- otherwise string-literals show up as global int-constants --- which blow up qualifier instantiation. - -literalConst tce l = (sort, mkLit l) - where - sort = typeSort tce $ literalType l - sym = stringSymbol $ "$$" ++ showPpr l - mkLit (MachInt n) = mkI n - mkLit (MachInt64 n) = mkI n - mkLit (MachWord n) = mkI n - mkLit (MachWord64 n) = mkI n - mkLit (LitInteger n _) = mkI n - mkLit _ = Nothing -- ELit sym sort - mkI = Just . ECon . I - ---------------------------------------------------------------- ----------------- Annotations and Solutions -------------------- ---------------------------------------------------------------- - -rTypeSortedReft :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> SortedReft -rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t) - -rTypeSort :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> Sort -rTypeSort tce = typeSort tce . toType - - ------------------------------------------------------------------------- ----------------- Auxiliary Stuff Used Elsewhere ------------------------ ------------------------------------------------------------------------- - --- MOVE TO TYPES -instance (Show tv, Show ty) => Show (RTAlias tv ty) where - show (RTA n as xs t p) = printf "type %s %s %s = %s -- defined at %s" n - (L.intercalate " " (show <$> as)) - (L.intercalate " " (show <$> xs)) - (show t) (show p) - ----------------------------------------------------------------- ------------- From Old Fixpoint --------------------------------- ----------------------------------------------------------------- - -typeUniqueSymbol :: Type -> Symbol -typeUniqueSymbol = stringSymbol . typeUniqueString - - -fApp c ts - | c == intFTyCon = FInt - | otherwise = FApp c ts - -typeSort :: TCEmb TyCon -> Type -> Sort -typeSort tce τ@(ForAllTy _ _) - = typeSortForAll tce τ -typeSort tce (FunTy τ1 τ2) - = typeSortFun tce τ1 τ2 -typeSort tce (TyConApp c τs) - = fApp ftc (typeSort tce <$> τs) - where ftc = fromMaybe (stringFTycon $ tyConName c) (M.lookup c tce) -typeSort _ τ - = FObj $ typeUniqueSymbol τ - -typeSortForAll tce τ - = genSort $ typeSort tce tbody - where genSort (FFunc _ t) = FFunc n (sortSubst su <$> t) - genSort t = FFunc n [sortSubst su t] - (as, tbody) = splitForAllTys τ - su = M.fromList $ zip sas (FVar <$> [0..]) - sas = (typeUniqueSymbol . TyVarTy) <$> as - n = length as - --- sortSubst su t@(FObj x) = fromMaybe t (M.lookup x su) --- sortSubst su (FFunc n ts) = FFunc n (sortSubst su <$> ts) --- sortSubst su (FApp c ts) = FApp c (sortSubst su <$> ts) --- sortSubst _ t = t - -tyConName c - | listTyCon == c = listConName - | TC.isTupleTyCon c = tupConName - | otherwise = showPpr c - -typeSortFun tce τ1 τ2 - = FFunc 0 sos - where sos = typeSort tce <$> τs - τs = τ1 : grabArgs [] τ2 -grabArgs τs (FunTy τ1 τ2 ) = grabArgs (τ1:τs) τ2 -grabArgs τs τ = reverse (τ:τs) - -mkDataConIdsTy (dc, t) = [expandProductType id t | id <- dataConImplicitIds dc] - -expandProductType x t - | ofType (varType x) == toRSort t = (x, t) - | otherwise = (x, t') - where t' = mkArrow as ps xts' tr - τs = fst $ splitFunTys $ toType t - (as, ps, t0) = bkUniv t - (xs, ts, tr) = bkArrow t0 - xts' = concatMap mkProductTy $ zip3 τs xs ts - -mkProductTy (τ, x, t) = maybe [(x, t)] f $ deepSplitProductType_maybe τ - where f = ((<$>) ((,) dummySymbol . ofType)) . forth4 - --- Move to misc -forth4 (_, _, _, x) = x - ------------------------------------------------------------------------------------------ --- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum) ------------------------------------------------------------------------------------------ - -classBinds (RCls c ts) - | isNumericClass c = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts] -classBinds _ = [] - -rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α - ------------------------------------------------------------------------------------------ ---------------------------- Termination Predicates -------------------------------------- ------------------------------------------------------------------------------------------ - -isDecreasing (RApp c _ _ _) - = isJust (sizeFunction (rTyConInfo c)) -isDecreasing _ - = False - -makeDecrType = mkDType [] [] - -mkDType xvs acc [(v, (x, t@(RApp c _ _ _)))] - = (x, ) $ t `strengthen` tr - where tr = uTop $ Reft (vv, [RConc $ pOr (r:acc)]) - r = cmpLexRef xvs (v', vv, f) - v' = varSymbol v - Just f = sizeFunction $ rTyConInfo c - vv = stringSymbol "vvRec" - -mkDType xvs acc ((v, (x, t@(RApp c _ _ _))):vxts) - = mkDType ((v', x, f):xvs) (r:acc) vxts - where r = cmpLexRef xvs (v', x, f) - v' = varSymbol v - Just f = sizeFunction $ rTyConInfo c - -cmpLexRef vxs (v, x, g) - = pAnd $ (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero) - : [PAtom Eq (f y) (f z) | (y, z, f) <- vxs] - ++ [PAtom Ge (f y) zero | (y, _, f) <- vxs] - where zero = ECon $ I 0 - ------------------------------------------------------------------------- --- | Pretty Printing Error Messages ------------------------------------ ------------------------------------------------------------------------- - --- Need to put this here intead of in Types, because it depends on the --- printer for SpecTypes, which lives in this module. - -instance PPrint Error where - pprint = ppError - -instance PPrint SrcSpan where - pprint = pprDoc - -instance Show Error where - show = showpp - -instance Exception Error -instance Exception [Error] - ------------------------------------------------------------------------- -ppError :: Error -> Doc ------------------------------------------------------------------------- -ppError (ErrSubType l s tA tE) - = text "Liquid Type Error:" <+> pprint l --- DO NOT DELETE --- $+$ (nest 4 $ text "Required Type:" <+> pprint tE) --- $+$ (nest 4 $ text "Actual Type:" <+> pprint tA) - -ppError (ErrParse l _ e) - = text "Error Parsing Specification:" <+> pprint l - $+$ (nest 4 $ pprint e) - -ppError (ErrTySpec l v t s) - = text "Error in Type Specification:" <+> pprint l - $+$ (v <+> dcolon <+> pprint t) - $+$ (nest 4 s) - -ppError (ErrInvt l t s) - = text "Error in Invariant Specification:" <+> pprint l - $+$ (nest 4 $ text "invariant " <+> pprint t $+$ s) - -ppError (ErrMeas l t s) - = text "Error in Measure Defiition:" <+> pprint l - $+$ (nest 4 $ text "measure " <+> pprint t $+$ s) - - -ppError (ErrDupSpecs l v ls) - = text "Multiple Specifications for" <+> v <> colon <+> pprint l - $+$ (nest 4 $ vcat $ pprint <$> ls) - -ppError (ErrGhc l s) - = text "GHC Error:" <+> pprint l - $+$ (nest 4 s) - -ppError (ErrMismatch l x τ t) - = text "Specified Type Does Not Refine Haskell Type for" <+> x <> colon <+> pprint l - $+$ text "Haskell:" <+> pprint τ - $+$ text "Liquid :" <+> pprint t - -ppError (ErrOther s) - = text "Unexpected Error: " - $+$ (nest 4 s) - - -------------------------------------------------------------------------------- - -mkTyConInfo :: TyCon -> [Int] -> [Int] -> (Maybe (Symbol -> Expr)) -> TyConInfo -mkTyConInfo c = TyConInfo pos neg - where pos = neutral ++ [i | (i, b) <- varsigns, b, i /= dindex] - neg = neutral ++ [i | (i, b) <- varsigns, not b, i /= dindex] - varsigns = L.nub $ concatMap goDCon $ TC.tyConDataCons c - initmap = zip (showPpr <$> tyvars) [0..n] - mkmap vs = zip (showPpr <$> vs) (repeat (dindex)) ++ initmap - goDCon dc = concatMap (go (mkmap (DataCon.dataConExTyVars dc)) True) - (DataCon.dataConOrigArgTys dc) - go m pos (ForAllTy v t) = go ((showPpr v, dindex):m) pos t - go m pos (TyVarTy v) = [(varLookup (showPpr v) m, pos)] - go m pos (AppTy t1 t2) = go m pos t1 ++ go m pos t2 - go m pos (TyConApp _ ts) = concatMap (go m pos) ts - go m pos (FunTy t1 t2) = go m (not pos) t1 ++ go m pos t2 - - varLookup v m = fromMaybe (errmsg v) $ L.lookup v m - tyvars = TC.tyConTyVars c - n = (TC.tyConArity c) - 1 - errmsg v = error $ "GhcMisc.getTyConInfo: var not found" ++ showPpr v - dindex = -1 - neutral = [0..n] L.\\ (fst <$> varsigns) - - - - diff --git a/Language/Haskell/Liquid/Tidy.hs b/Language/Haskell/Liquid/Tidy.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Tidy.hs +++ /dev/null @@ -1,101 +0,0 @@ -module Language.Haskell.Liquid.Tidy (tidySpecType) where - -import Outputable (showPpr) -- hiding (empty) -import Control.Applicative -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import qualified Data.List as L - -import Language.Fixpoint.Misc -import Language.Fixpoint.Names (symSepName) -import Language.Fixpoint.Types -import Language.Haskell.Liquid.GhcMisc (stringTyVar) -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.RefType ---------------------------------------------------------------------- ----------- SYB Magic: Cleaning Reftypes Up Before Rendering --------- ---------------------------------------------------------------------- - -tidySpecType :: SpecType -> SpecType -tidySpecType = tidyDSymbols - . tidySymbols - . tidyLocalRefas - . tidyFunBinds - . tidyTyVars - -tidySymbols :: SpecType -> SpecType -tidySymbols t = substa dropSuffix $ mapBind dropBind t - where - xs = S.fromList (syms t) - dropBind x = if x `S.member` xs then dropSuffix x else nonSymbol - dropSuffix = S . takeWhile (/= symSepName) . symbolString - -tidyLocalRefas :: SpecType -> SpecType -tidyLocalRefas = mapReft (txReft) - where - txReft (U (Reft (v,ras)) p) = U (Reft (v, dropLocals ras)) p - dropLocals = filter (not . any isTmp . syms) . flattenRefas - isTmp x = any (`L.isPrefixOf` (symbolString x)) [anfPrefix, "ds_"] - -isTmpSymbol x = any (`L.isPrefixOf` str) [anfPrefix, tempPrefix, "ds_"] - where str = symbolString x - - -tidyDSymbols :: SpecType -> SpecType -tidyDSymbols t = mapBind tx $ substa tx t - where - tx = bindersTx [x | x <- syms t, isTmp x] - isTmp = (tempPrefix `L.isPrefixOf`) . symbolString - -tidyFunBinds :: SpecType -> SpecType -tidyFunBinds t = mapBind tx $ substa tx t - where - tx = bindersTx $ filter isTmpSymbol $ funBinds t - -tidyTyVars :: SpecType -> SpecType -tidyTyVars t = subsTyVarsAll αβs t - where - -- zz = [(a, b) | (a, _, (RVar b _)) <- αβs] - αβs = zipWith (\α β -> (α, toRSort β, β)) αs βs - αs = L.nub (tyVars t) - βs = map (rVar . stringTyVar) pool - pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]] - - -bindersTx ds = \y -> M.lookupDefault y y m - where - m = M.fromList $ zip ds $ var <$> [1..] - var = stringSymbol . ('x' :) . show - - -tyVars (RAllP _ t) = tyVars t -tyVars (RAllT α t) = α : tyVars t -tyVars (RFun _ t t' _) = tyVars t ++ tyVars t' -tyVars (RAppTy t t' _) = tyVars t ++ tyVars t' -tyVars (RApp _ ts _ _) = concatMap tyVars ts -tyVars (RCls _ ts) = concatMap tyVars ts -tyVars (RVar α _) = [α] -tyVars (RAllE _ _ t) = tyVars t -tyVars (REx _ _ t) = tyVars t -tyVars (RExprArg _) = [] -tyVars (ROth _) = [] - -subsTyVarsAll ats = go - where - abm = M.fromList [(a, b) | (a, _, (RVar b _)) <- ats] - go (RAllT a t) = RAllT (M.lookupDefault a a abm) (go t) - go t = subsTyVars_meet ats t - - -funBinds (RAllT _ t) = funBinds t -funBinds (RAllP _ t) = funBinds t -funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2 -funBinds (RApp _ ts _ _) = concatMap funBinds ts -funBinds (RCls _ ts) = concatMap funBinds ts -funBinds (RAllE b t1 t2) = b : funBinds t1 ++ funBinds t2 -funBinds (REx b t1 t2) = b : funBinds t1 ++ funBinds t2 -funBinds (RVar _ _) = [] -funBinds (ROth _) = [] -funBinds (RAppTy t1 t2 r) = funBinds t1 ++ funBinds t2 -funBinds (RExprArg e) = [] - diff --git a/Language/Haskell/Liquid/TransformRec.hs b/Language/Haskell/Liquid/TransformRec.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/TransformRec.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Language.Haskell.Liquid.TransformRec ( - transformRecExpr - ) where - -import Bag -import Coercion -import Control.Arrow (second, (***)) -import Control.Monad.State -import CoreLint -import CoreSyn -import qualified Data.HashMap.Strict as M -import ErrUtils -import Id (idOccInfo, setIdInfo) -import IdInfo -import MkCore (mkCoreLams) -import SrcLoc -import Type (mkForAllTys) -import TypeRep -import Unique hiding (deriveUnique) -import Var -import Language.Haskell.Liquid.GhcMisc -import Language.Haskell.Liquid.Misc (mapSndM) - -import Data.List (foldl', isInfixOf) -import Control.Applicative ((<$>)) - -transformRecExpr :: CoreProgram -> CoreProgram -transformRecExpr cbs - | isEmptyBag $ filterBag isTypeError e - = {-trace "new cbs"-} pg - | otherwise - = error (showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e)) - where pg = scopeTr $ evalState (transPg cbs) initEnv - (_, e) = lintCoreBindings pg - -isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False -isTypeError _ = True - -scopeTr = outerScTr . innerScTr - -outerScTr = mapNonRec (go []) - where - go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes - go ack _ xes = ack ++ xes - -isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x -isCaseArg _ _ = False - -innerScTr = (mapBnd scTrans <$>) - -scTrans x e = mapExpr scTrans $ foldr Let e0 bs - where (bs, e0) = go [] x e - go bs x (Let b e) | isCaseArg x b = go (b:bs) x e - go bs x (Tick t e) = second (Tick t) $ go bs x e - go bs x e = (bs, e) - -type TE = State TrEnv - -data TrEnv = Tr { freshIndex :: !Int - , loc :: SrcSpan - } - -initEnv = Tr 0 noSrcSpan - -transPg = mapM transBd - -transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e) -transBd (Rec xes) = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes - -transExpr :: CoreExpr -> TE CoreExpr -transExpr e - | (isNonPolyRec e') && (not (null tvs)) - = trans tvs ids bs e' - | otherwise - = return e - where (tvs, ids, e'') = collectTyAndValBinders e - (bs, e') = collectNonRecLets e'' - -isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes) -isNonPolyRec _ = False - -nonPoly = null . fst . collectTyBinders - -collectNonRecLets = go [] - where go bs (Let b@(NonRec _ _) e') = go (b:bs) e' - go bs e' = (reverse bs, e') - -appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids) - -trans vs ids bs (Let (Rec xes) e) - = liftM (mkLam . mkLet) (makeTrans vs liveIds e') - where liveIds = mkAlive <$> ids - mkLet e = foldr Let e bs - mkLam e = foldr Lam e $ vs ++ liveIds - e' = Let (Rec xes') e - xes' = (second mkLet) <$> xes - -makeTrans vs ids (Let (Rec xes) e) - = do fids <- mapM (mkFreshIds vs ids) xs - let (ids', ys) = unzip fids - let yes = appTysAndIds vs ids <$> ys - ys' <- mapM fresh xs - let su = M.fromList $ zip xs (Var <$> ys') - let rs = zip ys' yes - let es' = zipWith (mkE ys) ids' es - let xes' = zip ys es' - return $ mkRecBinds rs (Rec xes') (sub su e) - where - (xs, es) = unzip xes - mkSu ys ids' = mkSubs ids vs ids' (zip xs ys) - mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e') - -mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b -mkRecBinds xes rs e = Let rs (foldl' f e xes) - where f e (x, xe) = Let (NonRec x xe) e - -mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2 - where s1 = (second (appTysAndIds tvs xs)) <$> ys - s2 = zip ids (Var <$> xs) - -mkFreshIds tvs ids x - = do ids' <- mapM fresh ids - let t = mkForAllTys tvs $ mkType (reverse ids') $ varType x - let x' = setVarType x t - return (ids', x') - where - mkType ids ty = foldl (\t x -> FunTy (varType x) t) ty ids - -class Freshable a where - fresh :: a -> TE a - -instance Freshable Int where - fresh _ = freshInt - -instance Freshable Unique where - fresh _ = freshUnique - -instance Freshable Var where - fresh v = liftM (setVarUnique v) freshUnique - -freshInt - = do s <- get - let n = freshIndex s - put s{freshIndex = n+1} - return n - -freshUnique = liftM (mkUnique 'X') freshInt - -mkAlive x - | isId x && isDeadOcc (idOccInfo x) - = setIdInfo x (setOccInfo (idInfo x) NoOccInfo) - | otherwise - = x - -class Subable a where - sub :: M.HashMap CoreBndr CoreExpr -> a -> a - subTy :: M.HashMap TyVar Type -> a -> a - -instance Subable CoreExpr where - sub s (Var v) = M.lookupDefault (Var v) v s - sub _ (Lit l) = Lit l - sub s (App e1 e2) = App (sub s e1) (sub s e2) - sub s (Lam b e) = Lam b (sub s e) - sub s (Let b e) = Let (sub s b) (sub s e) - sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a) - sub s (Cast e c) = Cast (sub s e) c - sub s (Tick t e) = Tick t (sub s e) - sub _ (Type t) = Type t - sub _ (Coercion c) = Coercion c - - subTy s (Var v) = Var (subTy s v) - subTy _ (Lit l) = Lit l - subTy s (App e1 e2) = App (subTy s e1) (subTy s e2) - subTy s (Lam b e) | isTyVar b = Lam v' (subTy s e) - where v' = case M.lookup b s of - Nothing -> b - Just (TyVarTy v) -> v - - subTy s (Lam b e) = Lam (subTy s b) (subTy s e) - subTy s (Let b e) = Let (subTy s b) (subTy s e) - subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a) - subTy s (Cast e c) = Cast (subTy s e) (subTy s c) - subTy s (Tick t e) = Tick t (subTy s e) - subTy s (Type t) = Type (subTy s t) - subTy s (Coercion c) = Coercion (subTy s c) - -instance Subable Coercion where - sub _ c = c - subTy _ _ = error "subTy Coercion" - -instance Subable (Alt Var) where - sub s (a, b, e) = (a, map (sub s) b, sub s e) - subTy s (a, b, e) = (a, map (subTy s) b, subTy s e) - -instance Subable Var where - sub s v | M.member v s = subVar $ s M.! v - | otherwise = v - subTy s v = setVarType v (subTy s (varType v)) - -subVar (Var x) = x -subVar _ = error "sub Var" - -instance Subable (Bind Var) where - sub s (NonRec x e) = NonRec (sub s x) (sub s e) - sub s (Rec xes) = Rec ((sub s *** sub s) <$> xes) - - subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e) - subTy s (Rec xes) = Rec ((subTy s *** subTy s) <$> xes) - -instance Subable Type where - sub _ e = e - subTy = substTysWith - -substTysWith s tv@(TyVarTy v) = M.lookupDefault tv v s -substTysWith s (FunTy t1 t2) = FunTy (substTysWith s t1) (substTysWith s t2) -substTysWith s (ForAllTy v t) = ForAllTy v (substTysWith (M.delete v s) t) -substTysWith s (TyConApp c ts) = TyConApp c (map (substTysWith s) ts) -substTysWith s (AppTy t1 t2) = AppTy (substTysWith s t1) (substTysWith s t2) - -mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes) -mapNonRec f (xe:xes) = xe : mapNonRec f xes -mapNonRec _ [] = [] - -mapBnd f (NonRec b e) = NonRec b (mapExpr f e) -mapBnd f (Rec bs) = Rec (map (second (mapExpr f)) bs) - -mapExpr f (Let b@(NonRec x _) e) = Let b (f x e) -mapExpr f (App e1 e2) = App (mapExpr f e1) (mapExpr f e2) -mapExpr f (Lam b e) = Lam b (mapExpr f e) -mapExpr f (Let bs e) = Let (mapBnd f bs) (mapExpr f e) -mapExpr f (Case e b t alt) = Case e b t (map (mapAlt f) alt) -mapExpr f (Tick t e) = Tick t (mapExpr f e) -mapExpr _ e = e - -mapAlt f (d, bs, e) = (d, bs, mapExpr f e) - --- Do not apply transformations to inner code - -mapBdM _ = return - --- mapBdM f (Let b e) = liftM2 Let (f b) (mapBdM f e) --- mapBdM f (App e1 e2) = liftM2 App (mapBdM f e1) (mapBdM f e2) --- mapBdM f (Lam b e) = liftM (Lam b) (mapBdM f e) --- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt) --- mapBdM f (Tick t e) = liftM (Tick t) (mapBdM f e) --- mapBdM _ e = return e --- --- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e) diff --git a/Language/Haskell/Liquid/Types.hs b/Language/Haskell/Liquid/Types.hs deleted file mode 100644 --- a/Language/Haskell/Liquid/Types.hs +++ /dev/null @@ -1,1069 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverlappingInstances #-} - --- | This module (should) contain all the global type definitions and basic --- instances. Need to gradually pull things into here, especially from @RefType@ - -module Language.Haskell.Liquid.Types ( - - -- * Options - Config (..) - - -- * Ghc Information - , GhcInfo (..) - , GhcSpec (..) - , TargetVars (..) - - -- * Located Things - , Located (..) - - -- * Symbols - , LocSymbol - , LocString - - -- * Data Constructors - , BDataCon (..) - - -- * Constructors and Destructors - , mkArrow, bkArrowDeep, bkArrow, safeBkArrow - , mkUnivs, bkUniv, bkClass - , rFun, rAppTy - - -- * Manipulating Predicate - , pvars - - -- * All these should be MOVE TO TYPES - , RTyVar (..), RType (..), RRType, BRType, RTyCon(..) - , TyConable (..), RefTypable (..), SubsTy (..), Ref(..) - , RTAlias (..), mapRTAVars - , BSort, BPVar, BareType, RSort, UsedPVar, RPVar, RReft, RefType - , PrType, SpecType - , PVar (..) , Predicate (..), UReft(..), DataDecl (..), TyConInfo(..) - , TyConP (..), DataConP (..) - - -- * Default unknown name - , dummyName, isDummy - - -- * Traversing `RType` - , efoldReft, foldReft - , mapReft, mapReftM - , mapBot, mapBind - - , isTrivial - - -- * Converting To and From Sort - , ofRSort, toRSort - , rTypeValueVar - , rTypeReft - , stripRTypeBase - - -- * Class for values that can be pretty printed - , PPrint (..) - , showpp - - -- * Printer Configuration - , PPEnv (..), ppEnv - - -- * Import handling - , ModName (..), ModType (..), isSrcImport, isSpecImport - , getModName, getModString - - -- * Refinement Type Aliases - , RTEnv (..), mapRT, mapRP, RTBareOrSpec - - -- * Final Result - , Result (..) - - -- * Different kinds of errors - , Error (..) - , ErrorResult - - -- * Source information associated with each constraint - , Cinfo (..) - ) - where - -import FastString (fsLit) -import SrcLoc (mkGeneralSrcSpan, SrcSpan) -import TyCon -import DataCon -import TypeRep hiding (maybeParen, pprArrowChain) -import Var -import Unique -import Literal -import Text.Printf -import GHC (Class, HscEnv, ModuleName, Name, moduleNameString) -import GHC (Class, HscEnv) -import Language.Haskell.Liquid.GhcMisc - -import Control.Monad (liftM, liftM2, liftM3) -import Control.DeepSeq -import Control.Applicative ((<$>)) -import Data.Typeable (Typeable) -import Data.Generics (Data) -import Data.Monoid hiding ((<>)) -import qualified Data.Foldable as F -import Data.Hashable -import qualified Data.HashMap.Strict as M -import qualified Data.HashSet as S -import Data.Function (on) -import Data.Maybe (maybeToList, fromMaybe) -import Data.Traversable hiding (mapM) -import Data.List (nub, union, unionBy) -import Text.Parsec.Pos (SourcePos, newPos) -import Text.Parsec.Error (ParseError) -import Text.PrettyPrint.HughesPJ -import Language.Fixpoint.Config hiding (Config) -import Language.Fixpoint.Misc -import Language.Fixpoint.Types hiding (Predicate) --- import qualified Language.Fixpoint.Types as F - -import CoreSyn (CoreBind) -import Var ------------------------------------------------------------------------------ --- | Command Line Config Options -------------------------------------------- ------------------------------------------------------------------------------ - --- NOTE: adding strictness annotations breaks the help message -data Config = Config { - files :: [FilePath] -- ^ source files to check - , idirs :: [FilePath] -- ^ path to directory for including specs - , diffcheck :: Bool -- ^ check subset of binders modified (+ dependencies) since last check - , binders :: [String] -- ^ set of binders to check - , noCheckUnknown :: Bool -- ^ whether to complain about specifications for unexported and unused values - , nofalse :: Bool -- ^ remove false predicates from the refinements - , notermination :: Bool -- ^ disable termination check - , totality :: Bool -- ^ check totality in definitions - , noPrune :: Bool -- ^ disable prunning unsorted Refinements - , maxParams :: Int -- ^ the maximum number of parameters to accept when mining qualifiers - , smtsolver :: SMTSolver -- ^ name of smtsolver to use [default: z3-API] - } deriving (Data, Typeable, Show, Eq) - ------------------------------------------------------------------------------ --- | Printer ---------------------------------------------------------------- ------------------------------------------------------------------------------ - -class PPrint a where - pprint :: a -> Doc - -showpp :: (PPrint a) => a -> String -showpp = render . pprint - --- pshow :: PPrint a => a -> String --- pshow = render . pprint - -instance PPrint a => PPrint (Maybe a) where - pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) - -instance PPrint a => PPrint [a] where - pprint = brackets . intersperse comma . map pprint - - - -instance (PPrint a, PPrint b) => PPrint (a,b) where - pprint (x, y) = (pprint x) <+> text ":" <+> (pprint y) - -data PPEnv - = PP { ppPs :: Bool - , ppTyVar :: Bool - } - -ppEnv = ppEnvPrintPreds -ppEnvCurrent = PP False False -ppEnvPrintPreds = PP True False - - ------------------------------------------------------------------------------ --- | Located Values --------------------------------------------------------- ------------------------------------------------------------------------------ - -data Located a = Loc { loc :: !SourcePos - , val :: a - } - -type LocSymbol = Located Symbol -type LocString = Located String - -dummyName = "dummy" - -isDummy :: (Show a) => a -> Bool -isDummy a = show a == dummyName - - -instance Fixpoint SourcePos where - toFix = text . show - -instance Fixpoint a => Fixpoint (Located a) where - toFix = toFix . val - -instance Symbolic a => Symbolic (Located a) where - symbol = symbol . val - -instance Expression a => Expression (Located a) where - expr = expr . val - -instance Functor Located where - fmap f (Loc l x) = Loc l (f x) - -instance F.Foldable Located where - foldMap f (Loc _ x) = f x - -instance Traversable Located where - traverse f (Loc l x) = Loc l <$> f x - -instance Show a => Show (Located a) where - show (Loc l x) = show x ++ " defined at " ++ show l - -instance Eq a => Eq (Located a) where - (Loc _ x) == (Loc _ y) = x == y - -instance Ord a => Ord (Located a) where - compare x y = compare (val x) (val y) - -instance Subable a => Subable (Located a) where - syms (Loc _ x) = syms x - substa f (Loc l x) = Loc l (substa f x) - substf f (Loc l x) = Loc l (substf f x) - subst su (Loc l x) = Loc l (subst su x) - -instance Hashable a => Hashable (Located a) where - hashWithSalt i = hashWithSalt i . val - - - ------------------------------------------------------------------- --- | GHC Information : Code & Spec ------------------------------ ------------------------------------------------------------------- - -data GhcInfo = GI { - env :: !HscEnv - , cbs :: ![CoreBind] - , impVars :: ![Var] - , defVars :: ![Var] - , useVars :: ![Var] - , hqFiles :: ![FilePath] - , imports :: ![String] - , includes :: ![FilePath] - , spec :: !GhcSpec - } - --- | The following is the overall type for /specifications/ obtained from --- parsing the target source and dependent libraries - -data GhcSpec = SP { - tySigs :: ![(Var, Located SpecType)] -- ^ Asserted/Assumed Reftypes - -- eg. see include/Prelude.spec - , ctor :: ![(Var, Located SpecType)] -- ^ Data Constructor Measure Sigs - -- eg. (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) } - , meas :: ![(Symbol, Located RefType)] -- ^ Measure Types - -- eg. len :: [a] -> Int - , invariants :: ![Located SpecType] -- ^ Data Type Invariants - -- eg. forall a. {v: [a] | len(v) >= 0} - , dconsP :: ![(DataCon, DataConP)] -- ^ Predicated Data-Constructors - -- e.g. see tests/pos/Map.hs - , tconsP :: ![(TyCon, TyConP)] -- ^ Predicated Type-Constructors - -- eg. see tests/pos/Map.hs - , freeSyms :: ![(Symbol, Var)] -- ^ List of `Symbol` free in spec and corresponding GHC var - -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs - , tcEmbeds :: TCEmb TyCon -- ^ How to embed GHC Tycons into fixpoint sorts - -- e.g. "embed Set as Set_set" from include/Data/Set.spec - , qualifiers :: ![Qualifier] -- ^ Qualifiers in Source/Spec files - -- e.g tests/pos/qualTest.hs - , tgtVars :: ![Var] -- ^ Top-level Binders To Verify (empty means ALL binders) - , decr :: ![(Var, [Int])] -- ^ Lexicographically ordered size witnesses 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 - , config :: !Config -- ^ Configuration Options - } - - -data TyConP = TyConP { freeTyVarsTy :: ![RTyVar] - , freePredTy :: ![(PVar RSort)] - , covPs :: ![Int] -- indexes of covariant predicate arguments - , contravPs :: ![Int] -- indexes of contravariant predicate arguments - , sizeFun :: !(Maybe (Symbol -> Expr)) - } - -data DataConP = DataConP { freeTyVars :: ![RTyVar] - , freePred :: ![(PVar RSort)] - , tyArgs :: ![(Symbol, SpecType)] - , tyRes :: !SpecType - } - - --- | Which Top-Level Binders Should be Verified -data TargetVars = AllVars | Only ![Var] - - --------------------------------------------------------------------- --- | Predicate Variables ------------------------------------------- --------------------------------------------------------------------- - --- MOVE TO TYPES -data PVar t - = PV { pname :: !Symbol - , ptype :: !t - , pargs :: ![(t, Symbol, Expr)] - } - deriving (Show) - -instance Eq (PVar t) where - pv == pv' = (pname pv == pname pv') {- UNIFY: What about: && eqArgs pv pv' -} - -instance Ord (PVar t) where - compare (PV n _ _) (PV n' _ _) = compare n n' - -instance Functor PVar where - fmap f (PV x t txys) = PV x (f t) (mapFst3 f <$> txys) - -instance (NFData a) => NFData (PVar a) where - rnf (PV n t txys) = rnf n `seq` rnf t `seq` rnf txys - -instance Hashable (PVar a) where - hashWithSalt i (PV n _ xys) = hashWithSalt i n -- : (thd3 <$> xys) - --------------------------------------------------------------------- ------------------- Predicates -------------------------------------- --------------------------------------------------------------------- - -type UsedPVar = PVar () -newtype Predicate = Pr [UsedPVar] -- deriving (Data, Typeable) - -instance NFData Predicate where - rnf _ = () - -instance Monoid Predicate where - mempty = pdTrue - mappend p p' = pdAnd [p, p'] - -instance (Monoid a) => Monoid (UReft a) where - mempty = U mempty mempty - mappend (U x y) (U x' y') = U (mappend x x') (mappend y y') - - -pdTrue = Pr [] -pdAnd ps = Pr (nub $ concatMap pvars ps) -pvars (Pr pvs) = pvs - --- MOVE TO TYPES -instance Subable UsedPVar where - syms pv = [ y | (_, x, EVar y) <- pargs pv, x /= y ] - subst s pv = pv { pargs = mapThd3 (subst s) <$> pargs pv } - substf f pv = pv { pargs = mapThd3 (substf f) <$> pargs pv } - substa f pv = pv { pargs = mapThd3 (substa f) <$> pargs pv } - - --- MOVE TO TYPES -instance Subable Predicate where - syms (Pr pvs) = concatMap syms pvs - subst s (Pr pvs) = Pr (subst s <$> pvs) - substf f (Pr pvs) = Pr (substf f <$> pvs) - substa f (Pr pvs) = Pr (substa f <$> pvs) - - - -instance NFData r => NFData (UReft r) where - rnf (U r p) = rnf r `seq` rnf p - -instance NFData PrType where - rnf _ = () - -instance NFData RTyVar where - rnf _ = () - - --- MOVE TO TYPES -newtype RTyVar = RTV TyVar - -data RTyCon = RTyCon - { rTyCon :: !TyCon -- GHC Type Constructor - , rTyConPs :: ![RPVar] -- Predicate Parameters - , rTyConInfo :: !TyConInfo -- TyConInfo - } - -- deriving (Data, Typeable) - ------------------------------------------------------------------------ ------------ TyCon get CoVariance - ContraVariance Info ---------------- ------------------------------------------------------------------------ - --- indexes start from 0 and type or predicate arguments can be both --- covariant and contravaariant --- eg, for the below Foo dataType --- data Foo a b c d

Prop, q :: Int -> Prop, r :: a -> Prop> --- = F (a -> b

) | Q (c -> a) | G (Int -> a) --- there will be --- covariantTyArgs = [0, 1, 3], for type arguments a, b and d --- contravariantTyArgs = [0, 2, 3], for type arguments a, c and d --- covariantPsArgs = [0, 2], for predicate arguments p and r --- contravariantPsArgs = [1, 2], for predicate arguments q and r --- --- Note, d does not appear in the data definition, we enforce BOTH --- con - contra variance - -data TyConInfo = TyConInfo - { covariantTyArgs :: ![Int] -- indexes of covariant type arguments - , contravariantTyArgs :: ![Int] -- indexes of contravariant type arguments - , covariantPsArgs :: ![Int] -- indexes of covariant predicate arguments - , contravariantPsArgs :: ![Int] -- indexes of contravariant predicate arguments - , sizeFunction :: !(Maybe (Symbol -> Expr)) - } - - --------------------------------------------------------------------- ----- Unified Representation of Refinement Types -------------------- --------------------------------------------------------------------- - --- MOVE TO TYPES -data RType p c tv r - = RVar { - rt_var :: !tv - , rt_reft :: !r - } - - | RFun { - rt_bind :: !Symbol - , rt_in :: !(RType p c tv r) - , rt_out :: !(RType p c tv r) - , rt_reft :: !r - } - - | RAllT { - rt_tvbind :: !tv - , rt_ty :: !(RType p c tv r) - } - - | RAllP { - rt_pvbind :: !(PVar (RType p c tv ())) - , rt_ty :: !(RType p c tv r) - } - - | RApp { - rt_tycon :: !c - , rt_args :: ![(RType p c tv r)] - , rt_pargs :: ![Ref (RType p c tv ()) r (RType p c tv r)] - , rt_reft :: !r - } - - | RCls { - rt_class :: !p - , rt_args :: ![(RType p c tv r)] - } - - | RAllE { - rt_bind :: !Symbol - , rt_allarg :: !(RType p c tv r) - , rt_ty :: !(RType p c tv r) - } - - | REx { - rt_bind :: !Symbol - , rt_exarg :: !(RType p c tv r) - , rt_ty :: !(RType p c tv r) - } - - | RExprArg Expr -- ^ For expression arguments to type aliases - -- see tests/pos/vector2.hs - | RAppTy{ - rt_arg :: !(RType p c tv r) - , rt_res :: !(RType p c tv r) - , rt_reft :: !r - } - - | ROth !String - --- MOVE TO TYPES - -data Ref t s m - = RMono [(Symbol, t)] s - | RPoly [(Symbol, t)] m - --- MOVE TO TYPES -data UReft r - = U { ur_reft :: !r, ur_pred :: !Predicate } - --- MOVE TO TYPES -type BRType = RType String String String -type RRType = RType Class RTyCon RTyVar - -type BSort = BRType () -type RSort = RRType () - -type BPVar = PVar BSort -type RPVar = PVar RSort - -type RReft = UReft Reft -type PrType = RRType Predicate -type BareType = BRType RReft -type SpecType = RRType RReft -type RefType = RRType Reft - - -class SubsTy tv ty a where - subt :: (tv, ty) -> a -> a - - --- MOVE TO TYPES -class (Eq c) => TyConable c where - isFun :: c -> Bool - isList :: c -> Bool - isTuple :: c -> Bool - ppTycon :: c -> Doc - --- MOVE TO TYPES -class ( TyConable c - , Eq p, Eq c, Eq tv - , Hashable tv - , Reftable r - , PPrint r - ) => RefTypable p c tv r - where - ppCls :: p -> [RType p c tv r] -> Doc - ppRType :: Prec -> RType p c tv r -> Doc - -- ppRType = ppr_rtype True -- False - -- ppBase :: r -> Doc -> Doc - --------------------------------------------------------------------------- --- | Values Related to Specifications ------------------------------------ --------------------------------------------------------------------------- - --- | Data type refinements -data DataDecl = D { tycName :: String -- ^ Type Constructor Name - , tycTyVars :: [String] -- ^ Tyvar Parameters - , tycPVars :: [PVar BSort] -- ^ PVar Parameters - , tycDCons :: [(String, [(String, BareType)])] -- ^ [DataCon, [(fieldName, fieldType)]] - , tycSrcPos :: !SourcePos -- ^ Source Position - , tycSFun :: (Maybe (Symbol -> Expr)) -- ^ Measure that should decrease in recursive calls - } - -- deriving (Show) - --- | Refinement Type Aliases - -data RTAlias tv ty - = RTA { rtName :: String - , rtTArgs :: [tv] - , rtVArgs :: [tv] - , rtBody :: ty - , srcPos :: SourcePos - } - -mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt - , rtVArgs = f <$> rtVArgs rt - } - --- | Datacons - -data BDataCon a - = BDc a -- ^ Raw named data constructor - | BTup Int -- ^ Tuple constructor + arity - deriving (Eq, Ord, Show) - -instance Functor BDataCon where - fmap f (BDc x) = BDc (f x) - fmap f (BTup i) = BTup i - -instance Hashable a => Hashable (BDataCon a) where - hashWithSalt i (BDc x) = hashWithSalt i x - hashWithSalt i (BTup j) = hashWithSalt i j - ------------------------------------------------------------------------- --- | Constructor and Destructors for RTypes ---------------------------- ------------------------------------------------------------------------- - -mkArrow αs πs xts = mkUnivs αs πs . mkArrs xts - where - mkArrs xts t = foldr (uncurry rFun) t xts - -bkArrowDeep (RAllT _ t) = bkArrowDeep t -bkArrowDeep (RAllP _ t) = bkArrowDeep t -bkArrowDeep (RFun x t t' _) = let (xs, ts, t'') = bkArrowDeep t' in (x:xs, t:ts, t'') -bkArrowDeep t = ([], [], t) - -bkArrow (RFun x t t' _) = let (xs, ts, t'') = bkArrow t' in (x:xs, t:ts, t'') -bkArrow t = ([], [], t) - -safeBkArrow (RAllT _ _) = errorstar "safeBkArrow on RAllT" -safeBkArrow (RAllP _ _) = errorstar "safeBkArrow on RAllT" -safeBkArrow t = bkArrow t - -mkUnivs αs πs t = foldr RAllT (foldr RAllP t πs) αs - -bkUniv :: RType t t1 a t2 -> ([a], [PVar (RType t t1 a ())], RType t t1 a t2) -bkUniv (RAllT α t) = let (αs, πs, t') = bkUniv t in (α:αs, πs, t') -bkUniv (RAllP π t) = let (αs, πs, t') = bkUniv t in (αs, π:πs, t') -bkUniv t = ([], [], t) - -bkClass (RFun _ (RCls c t) t' _) = let (cs, t'') = bkClass t' in ((c, t):cs, t'') -bkClass t = ([], t) - -rFun b t t' = RFun b t t' top -rAppTy t t' = RAppTy t t' top - - --------------------------------------------- - -instance (PPrint r, Reftable r) => Reftable (UReft r) where - isTauto = isTauto_ureft - -- ppTy (U r p) d = ppTy r (ppTy p d) - ppTy = ppTy_ureft - toReft (U r _) = toReft r - params (U r _) = params r - bot (U r _) = U (bot r) (Pr []) - -isTauto_ureft u = isTauto (ur_reft u) && isTauto (ur_pred u) - -ppTy_ureft u@(U r p) d - | isTauto_ureft u = d - | otherwise = ppr_reft r (ppTy p d) - -ppr_reft r d = braces (toFix v <+> colon <+> d <+> text "|" <+> pprint r') - where - r'@(Reft (v, _)) = toReft r - - -instance Subable r => Subable (UReft r) where - syms (U r p) = syms r ++ syms p - subst s (U r z) = U (subst s r) (subst s z) - substf f (U r z) = U (substf f r) (substf f z) - substa f (U r z) = U (substa f r) (substa f z) - -instance (Reftable r, RefTypable p c tv r) => Subable (Ref (RType p c tv ()) r (RType p c tv r)) where - syms (RMono ss r) = (fst <$> ss) ++ syms r - syms (RPoly ss r) = (fst <$> ss) ++ syms r - - subst su (RMono ss r) = RMono ss (subst su r) - subst su (RPoly ss t) = RPoly ss (subst su <$> t) - - substf f (RMono ss r) = RMono ss (substf f r) - substf f (RPoly ss t) = RPoly ss (substf f <$> t) - substa f (RMono ss r) = RMono ss (substa f r) - substa f (RPoly ss t) = RPoly ss (substa f <$> t) - -instance (Subable r, RefTypable p c tv r) => Subable (RType p c tv r) where - syms = foldReft (\r acc -> syms r ++ acc) [] - substa f = mapReft (substa f) - substf f = emapReft (substf . substfExcept f) [] - subst su = emapReft (subst . substExcept su) [] - subst1 t su = emapReft (\xs r -> subst1Except xs r su) [] t - - - - -instance Reftable Predicate where - isTauto (Pr ps) = null ps - - bot (Pr _) = errorstar "No BOT instance for Predicate" - -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX. - ppTy r d | isTauto r = d - | not (ppPs ppEnv) = d - | otherwise = d <> (angleBrackets $ pprint r) - - toReft = errorstar "TODO: instance of toReft for Predicate" - params = errorstar "TODO: instance of params for Predicate" - - ---------------------------------------------------------------- ---------------------------- Visitors -------------------------- ---------------------------------------------------------------- - -isTrivial t = foldReft (\r b -> isTauto r && b) True t - -instance Functor UReft where - fmap f (U r p) = U (f r) p - -instance Functor (RType a b c) where - fmap = mapReft - --- instance Fold.Foldable (RType a b c) where --- foldr = foldReft - -mapReft :: (r1 -> r2) -> RType p c tv r1 -> RType p c tv r2 -mapReft f = emapReft (\_ -> f) [] - -emapReft :: ([Symbol] -> r1 -> r2) -> [Symbol] -> RType p c tv r1 -> RType p c tv r2 - -emapReft f γ (RVar α r) = RVar α (f γ r) -emapReft f γ (RAllT α t) = RAllT α (emapReft f γ t) -emapReft f γ (RAllP π t) = RAllP π (emapReft f γ t) -emapReft f γ (RFun x t t' r) = RFun x (emapReft f γ t) (emapReft f (x:γ) t') (f γ r) -emapReft f γ (RApp c ts rs r) = RApp c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r) -emapReft f γ (RCls c ts) = RCls c (emapReft f γ <$> ts) -emapReft f γ (RAllE z t t') = RAllE z (emapReft f γ t) (emapReft f γ t') -emapReft f γ (REx z t t') = REx z (emapReft f γ t) (emapReft f γ t') -emapReft _ _ (RExprArg e) = RExprArg e -emapReft f γ (RAppTy t t' r) = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r) -emapReft _ _ (ROth s) = ROth s - -emapRef :: ([Symbol] -> t -> s) -> [Symbol] -> Ref (RType p c tv ()) t (RType p c tv t) -> Ref (RType p c tv ()) s (RType p c tv s) -emapRef f γ (RMono s r) = RMono s $ f γ r -emapRef f γ (RPoly s t) = RPoly s $ emapReft f γ t - ------------------------------------------------------------------------------------------------------- - - -mapReftM :: (Monad m) => (r1 -> m r2) -> RType p c tv r1 -> m (RType p c tv r2) -mapReftM f (RVar α r) = liftM (RVar α) (f r) -mapReftM f (RAllT α t) = liftM (RAllT α) (mapReftM f t) -mapReftM f (RAllP π t) = liftM (RAllP π) (mapReftM f t) -mapReftM f (RFun x t t' r) = liftM3 (RFun x) (mapReftM f t) (mapReftM f t') (f r) -mapReftM f (RApp c ts rs r) = liftM3 (RApp c) (mapM (mapReftM f) ts) (mapM (mapRefM f) rs) (f r) -mapReftM f (RCls c ts) = liftM (RCls c) (mapM (mapReftM f) ts) -mapReftM f (RAllE z t t') = liftM2 (RAllE z) (mapReftM f t) (mapReftM f t') -mapReftM f (REx z t t') = liftM2 (REx z) (mapReftM f t) (mapReftM f t') -mapReftM _ (RExprArg e) = return $ RExprArg e -mapReftM f (RAppTy t t' r) = liftM3 (RAppTy) (mapReftM f t) (mapReftM f t') (f r) -mapReftM _ (ROth s) = return $ ROth s - -mapRefM :: (Monad m) => (t -> m s) -> Ref (RType p c tv ()) t (RType p c tv t) -> m (Ref (RType p c tv ()) s (RType p c tv s)) -mapRefM f (RMono s r) = liftM (RMono s) (f r) -mapRefM f (RPoly s t) = liftM (RPoly s) (mapReftM f t) - --- foldReft :: (r -> a -> a) -> a -> RType p c tv r -> a -foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) emptySEnv - --- efoldReft :: Reftable r =>(p -> [RType p c tv r] -> [(Symbol, a)])-> (RType p c tv r -> a)-> (SEnv a -> Maybe (RType p c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType p c tv r-> c1 -efoldReft cb g f = go - where - -- folding over RType - go γ z me@(RVar _ r) = f γ (Just me) r z - go γ z (RAllT _ t) = go γ z t - go γ z (RAllP _ t) = go γ z t - go γ z me@(RFun _ (RCls c ts) t' r) = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t') - go γ z me@(RFun x t t' r) = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t') - go γ z me@(RApp _ ts rs r) = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs) - - go γ z (RCls c ts) = go' γ z ts - go γ z (RAllE x t t') = go (insertSEnv x (g t) γ) (go γ z t) t' - go γ z (REx x t t') = go (insertSEnv x (g t) γ) (go γ z t) t' - go _ z (ROth _) = z - go γ z me@(RAppTy t t' r) = f γ (Just me) r (go γ (go γ z t) t') - go _ z (RExprArg _) = z - - -- folding over Ref - ho γ z (RMono ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z - ho γ z (RPoly ss t) = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t - - -- folding over [RType] - go' γ z ts = foldr (flip $ go γ) z ts - - -- folding over [Ref] - ho' γ z rs = foldr (flip $ ho γ) z rs - --- ORIG delete after regrtest-ing specerror --- -- efoldReft :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> RType p c tv r -> a --- efoldReft g f γ z me@(RVar _ r) = f γ (Just me) r z --- efoldReft g f γ z (RAllT _ t) = efoldReft g f γ z t --- efoldReft g f γ z (RAllP _ t) = efoldReft g f γ z t --- efoldReft g f γ z me@(RFun x t t' r) = f γ (Just me) r (efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t') --- efoldReft g f γ z me@(RApp _ ts rs r) = f γ (Just me) r (efoldRefs g f γ (efoldRefts g f (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs) --- efoldReft g f γ z (RCls _ ts) = efoldRefts g f γ z ts --- efoldReft g f γ z (RAllE x t t') = efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t' --- efoldReft g f γ z (REx x t t') = efoldReft g f (insertSEnv x (g t) γ) (efoldReft g f γ z t) t' --- efoldReft _ _ _ z (ROth _) = z --- efoldReft g f γ z me@(RAppTy t t' r) = f γ (Just me) r (efoldReft g f γ (efoldReft g f γ z t) t') --- efoldReft _ _ _ z (RExprArg _) = z --- --- -- efoldRefts :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> [RType p c tv r] -> a --- efoldRefts g f γ z ts = foldr (flip $ efoldReft g f γ) z ts --- --- -- efoldRefs :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> [Ref r (RType p c tv r)] -> a --- efoldRefs g f γ z rs = foldr (flip $ efoldRef g f γ) z rs --- --- -- efoldRef :: (RType p c tv r -> b) -> (SEnv b -> Maybe (RType p c tv r) -> r -> a -> a) -> SEnv b -> a -> Ref r (RType p c tv r) -> a --- efoldRef g f γ z (RMono ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z --- efoldRef g f γ z (RPoly ss t) = efoldReft g f (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t - -mapBot f (RAllT α t) = RAllT α (mapBot f t) -mapBot f (RAllP π t) = RAllP π (mapBot f t) -mapBot f (RFun x t t' r) = RFun x (mapBot f t) (mapBot f t') r -mapBot f (RAppTy t t' r) = RAppTy (mapBot f t) (mapBot f t') r -mapBot f (RApp c ts rs r) = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r -mapBot f (RCls c ts) = RCls c (mapBot f <$> ts) -mapBot f (REx b t1 t2) = REx b (mapBot f t1) (mapBot f t2) -mapBot f (RAllE b t1 t2) = RAllE b (mapBot f t1) (mapBot f t2) -mapBot f t' = f t' -mapBotRef _ (RMono s r) = RMono s $ r -mapBotRef f (RPoly s t) = RPoly s $ mapBot f t - -mapBind f (RAllT α t) = RAllT α (mapBind f t) -mapBind f (RAllP π t) = RAllP π (mapBind f t) -mapBind f (RFun b t1 t2 r) = RFun (f b) (mapBind f t1) (mapBind f t2) r -mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r -mapBind f (RCls c ts) = RCls c (mapBind f <$> ts) -mapBind f (RAllE b t1 t2) = RAllE (f b) (mapBind f t1) (mapBind f t2) -mapBind f (REx b t1 t2) = REx (f b) (mapBind f t1) (mapBind f t2) -mapBind _ (RVar α r) = RVar α r -mapBind _ (ROth s) = ROth s -mapBind f (RAppTy t1 t2 r) = RAppTy (mapBind f t1) (mapBind f t2) r -mapBind _ (RExprArg e) = RExprArg e - -mapBindRef f (RMono s r) = RMono (mapFst f <$> s) r -mapBindRef f (RPoly s t) = RPoly (mapFst f <$> s) $ mapBind f t - - --------------------------------------------------- -ofRSort :: Reftable r => RType p c tv () -> RType p c tv r -ofRSort = fmap (\_ -> top) - -toRSort :: RType p c tv r -> RType p c tv () -toRSort = stripQuantifiers . mapBind (const dummySymbol) . fmap (const ()) - -stripQuantifiers (RAllT α t) = RAllT α (stripQuantifiers t) -stripQuantifiers (RAllP _ t) = stripQuantifiers t -stripQuantifiers (RAllE _ _ t) = stripQuantifiers t -stripQuantifiers (REx _ _ t) = stripQuantifiers t -stripQuantifiers (RFun x t t' r) = RFun x (stripQuantifiers t) (stripQuantifiers t') r -stripQuantifiers (RAppTy t t' r) = RAppTy (stripQuantifiers t) (stripQuantifiers t') r -stripQuantifiers (RApp c ts rs r) = RApp c (stripQuantifiers <$> ts) (stripQuantifiersRef <$> rs) r -stripQuantifiers (RCls c ts) = RCls c (stripQuantifiers <$> ts) -stripQuantifiers t = t -stripQuantifiersRef (RPoly s t) = RPoly s $ stripQuantifiers t -stripQuantifiersRef r = r - - -insertsSEnv = foldr (\(x, t) γ -> insertSEnv x t γ) - -rTypeValueVar :: (Reftable r) => RType p c tv r -> Symbol -rTypeValueVar t = vv where Reft (vv,_) = rTypeReft t -rTypeReft :: (Reftable r) => RType p c tv r -> Reft -rTypeReft = fromMaybe top . fmap toReft . stripRTypeBase - --- stripRTypeBase :: RType a -> Maybe a -stripRTypeBase (RApp _ _ _ x) - = Just x -stripRTypeBase (RVar _ x) - = Just x -stripRTypeBase (RFun _ _ _ x) - = Just x -stripRTypeBase _ - = Nothing - ------------------------------------------------------------------------------ --- | PPrint ----------------------------------------------------------------- ------------------------------------------------------------------------------ - -instance PPrint SourcePos where - pprint = text . show - -instance PPrint () where - pprint = text . show - -instance PPrint String where - pprint = text - -instance PPrint a => PPrint (Located a) where - pprint = pprint . val - -instance PPrint Int where - pprint = toFix - -instance PPrint Integer where - pprint = toFix - -instance PPrint Constant where - pprint = toFix - -instance PPrint Brel where - pprint Eq = text "==" - pprint Ne = text "/=" - pprint r = toFix r - -instance PPrint Bop where - pprint = toFix - -instance PPrint Sort where - pprint = toFix - -instance PPrint Symbol where - pprint = toFix - -instance PPrint Expr where - pprint (EApp f es) = parens $ intersperse empty $ (pprint f) : (pprint <$> es) - pprint (ECon c) = pprint c - pprint (EVar s) = pprint s - pprint (ELit s _) = pprint s - pprint (EBin o e1 e2) = parens $ pprint e1 <+> pprint o <+> pprint e2 - pprint (EIte p e1 e2) = parens $ text "if" <+> pprint p <+> text "then" <+> pprint e1 <+> text "else" <+> pprint e2 - pprint (ECst e so) = parens $ pprint e <+> text " : " <+> pprint so - pprint (EBot) = text "_|_" - -instance PPrint Pred where - pprint PTop = text "???" - pprint PTrue = trueD - pprint PFalse = falseD - pprint (PBexp e) = parens $ pprint e - pprint (PNot p) = parens $ text "not" <+> parens (pprint p) - pprint (PImp p1 p2) = parens $ (pprint p1) <+> text "=>" <+> (pprint p2) - pprint (PIff p1 p2) = parens $ (pprint p1) <+> text "<=>" <+> (pprint p2) - pprint (PAnd ps) = parens $ pprintBin trueD andD ps - pprint (POr ps) = parens $ pprintBin falseD orD ps - pprint (PAtom r e1 e2) = parens $ pprint e1 <+> pprint r <+> pprint e2 - pprint (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p - -trueD = text "true" -falseD = text "false" -andD = text " &&" -orD = text " ||" - -pprintBin b _ [] = b -pprintBin _ o xs = intersperse o $ pprint <$> xs - --- pprintBin b o [] = b --- pprintBin b o [x] = pprint x --- pprintBin b o (x:xs) = pprint x <+> o <+> pprintBin b o xs - -instance PPrint a => PPrint (PVar a) where - pprint (PV s _ xts) = pprint s <+> hsep (pprint <$> dargs xts) - where - dargs = map thd3 . takeWhile (\(_, x, y) -> EVar x /= nexpr y) - nexpr (EVar (S ss)) = EVar $ stringSymbol ss - nexpr e = e - -instance PPrint Predicate where - pprint (Pr []) = text "True" - pprint (Pr pvs) = hsep $ punctuate (text "&") (map pprint pvs) - -instance PPrint Refa where - pprint (RConc p) = pprint p - pprint k = toFix k - -instance PPrint Reft where - pprint r@(Reft (_,ras)) - | isTauto r = text "true" - | otherwise = {- intersperse comma -} pprintBin trueD andD $ flattenRefas ras - -instance PPrint SortedReft where - pprint (RR so (Reft (v, ras))) - = braces - $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras - ------------------------------------------------------------------------- --- | Error Data Type --------------------------------------------------- ------------------------------------------------------------------------- - -type ErrorResult = FixResult Error - -data Error = - ErrSubType { pos :: !SrcSpan - , msg :: !Doc - , act :: !SpecType - , exp :: !SpecType - } -- ^ liquid type error - - | ErrParse { pos :: !SrcSpan - , msg :: !Doc - , err :: !ParseError - } -- ^ specification parse error - | ErrTySpec { pos :: !SrcSpan - , var :: !Doc - , typ :: !SpecType - , msg :: !Doc - } -- ^ sort error in specification - | ErrDupSpecs { pos :: !SrcSpan - , var :: !Doc - , locs:: ![SrcSpan] - } -- ^ multiple specs for same binder error - | ErrInvt { pos :: !SrcSpan - , inv :: !SpecType - , msg :: !Doc - } -- ^ Invariant sort error - | ErrMeas { pos :: !SrcSpan - , ms :: !Symbol - , msg :: !Doc - } -- ^ Measure sort error - | ErrGhc { pos :: !SrcSpan - , msg :: !Doc - } -- ^ GHC error: parsing or type checking - | ErrMismatch { pos :: !SrcSpan - , var :: !Doc - , hs :: !Type - , exp :: !SpecType - } -- ^ Mismatch between Liquid and Haskell types - | ErrOther { msg :: !Doc - } -- ^ Unexpected PANIC - deriving (Typeable) - -instance Eq Error where - e1 == e2 = pos e1 == pos e2 - -instance Ord Error where - e1 <= e2 = pos e1 <= pos e2 - ------------------------------------------------------------------------- --- | Source Information Associated With Constraints -------------------- ------------------------------------------------------------------------- - -data Cinfo = Ci { ci_loc :: !SrcSpan - , ci_err :: !(Maybe Error) - } - deriving (Eq, Ord) - -instance NFData Cinfo - - ------------------------------------------------------------------------- --- | Converting Results To Answers ------------------------------------- ------------------------------------------------------------------------- - -class Result a where - result :: a -> FixResult Error - -instance Result [Error] where - result es = Crash es "" - -instance Result Error where - result (ErrOther d) = UnknownError d - result e = result [e] - -instance Result (FixResult Cinfo) where - result = fmap cinfoError - --------------------------------------------------------------------------------- ---- Module Names --------------------------------------------------------------------------------- - -data ModName = ModName !ModType !ModuleName deriving (Eq,Ord) - -instance Show ModName where - show = getModString - -data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord) - -isSrcImport (ModName SrcImport _) = True -isSrcImport _ = False - -isSpecImport (ModName SpecImport _) = True -isSpecImport _ = False - -getModName (ModName _ m) = m - -getModString = moduleNameString . getModName - - -------------------------------------------------------------------------------- ------------ Refinement Type Aliases ------------------------------------------- -------------------------------------------------------------------------------- - -type RTBareOrSpec = Either (ModName, (RTAlias String BareType)) - (RTAlias RTyVar SpecType) - -type RTPredAlias = Either (ModName, RTAlias Symbol Pred) - (RTAlias Symbol Pred) - -data RTEnv = RTE { typeAliases :: M.HashMap String RTBareOrSpec - , predAliases :: M.HashMap String RTPredAlias - } - -instance Monoid RTEnv where - (RTE ta1 pa1) `mappend` (RTE ta2 pa2) = RTE (ta1 `M.union` ta2) (pa1 `M.union` pa2) - mempty = RTE M.empty M.empty - -mapRT f e = e { typeAliases = f $ typeAliases e } -mapRP f e = e { predAliases = f $ predAliases e } - -cinfoError (Ci _ (Just e)) = e -cinfoError (Ci l _) = ErrOther $ text $ "Cinfo:" ++ (showPpr l) - diff --git a/Liquid.hs b/Liquid.hs --- a/Liquid.hs +++ b/Liquid.hs @@ -1,97 +1,98 @@ -{-# LANGUAGE BangPatterns, TupleSections #-} - -import qualified Data.HashMap.Strict as M --- import qualified Control.Exception as Ex --- import Data.Maybe (catMaybes) -import Data.Monoid (mconcat) -import System.Exit -import Control.Applicative ((<$>)) -import Control.DeepSeq -import Control.Monad (when) - -import CoreSyn --- import FastString --- import GHC --- import HscMain --- import RdrName -import Var +{-# LANGUAGE TupleSections #-} -import System.Console.CmdArgs.Verbosity (whenLoud) -import System.Console.CmdArgs.Default -import Language.Fixpoint.Config (Config (..)) -import Language.Fixpoint.Files --- import Language.Fixpoint.Names -import Language.Fixpoint.Misc --- import Language.Fixpoint.Names (dropModuleNames) -import Language.Fixpoint.Interface -import Language.Fixpoint.Types (sinfo, showFix, isFalse) +import Data.Monoid (mconcat, mempty) +import System.Exit +import Control.Applicative ((<$>)) +import Control.DeepSeq +import Text.PrettyPrint.HughesPJ +import CoreSyn +import Var +import System.Console.CmdArgs.Verbosity (whenLoud) +import System.Console.CmdArgs.Default +import qualified Language.Fixpoint.Config as FC import qualified Language.Haskell.Liquid.DiffCheck as DC -import Language.Haskell.Liquid.Misc -import Language.Haskell.Liquid.Types -import Language.Haskell.Liquid.CmdLine -import Language.Haskell.Liquid.GhcInterface -import Language.Haskell.Liquid.Constraint -import Language.Haskell.Liquid.TransformRec +import Language.Fixpoint.Files +import Language.Fixpoint.Misc +import Language.Fixpoint.Interface +import Language.Fixpoint.Types (sinfo) +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.Errors +import Language.Haskell.Liquid.CmdLine +import Language.Haskell.Liquid.GhcInterface +import Language.Haskell.Liquid.Constraint +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) - exitWith $ resultExit res - -checkOne cfg0 t = getGhcInfo cfg0 t >>= either (exitWithResult t Nothing) (liquidOne t) + exitWith $ resultExit $ o_result res +checkOne :: Config -> FilePath -> IO (Output Doc) +checkOne cfg0 t = getGhcInfo cfg0 t >>= either errOut (liquidOne t) + where + errOut r = exitWithResult cfg0 t $ mempty { o_result = r} +liquidOne :: FilePath -> GhcInfo -> IO (Output Doc) liquidOne target info = - do donePhase Loud "Extracted Core From GHC" + do donePhase Loud "Extracted Core using GHC" let cfg = config $ spec info + whenLoud $ do putStrLn "**** Config **************************************************" + print cfg whenLoud $ do putStrLn $ showpp info putStrLn "*************** Original CoreBinds ***************************" putStrLn $ showpp (cbs info) - let cbs' = transformRecExpr (cbs info) + let cbs' = transformScope (cbs info) whenLoud $ do donePhase Loud "transformRecExpr" putStrLn "*************** Transform Rec Expr CoreBinds *****************" putStrLn $ showpp cbs' putStrLn "*************** Slicing Out Unchanged CoreBinds *****************" - (pruned, cbs'') <- prune cfg cbs' target info - let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info {cbs = cbs''} + dc <- prune cfg cbs' target info + let cbs'' = maybe cbs' DC.newBinds dc + let cgi = {-# SCC "generateConstraints" #-} generateConstraints $! info {cbs = cbs''} cgi `deepseq` donePhase Loud "generateConstraints" - -- whenLoud $ do donePhase Loud "START: Write CGI (can be slow!)" - -- {-# SCC "writeCGI" #-} writeCGI target cgi - -- donePhase Loud "FINISH: Write CGI" - (r, sol) <- solveCs cfg target cgi info - _ <- when (diffcheck cfg) $ DC.save target + -- SUPER SLOW: ONLY FOR DESPERATE DEBUGGING + -- SUPER SLOW: whenLoud $ do donePhase Loud "START: Write CGI (can be slow!)" + -- SUPER SLOW: {-# SCC "writeCGI" #-} writeCGI target cgi + -- SUPER SLOW: donePhase Loud "FINISH: Write CGI" + out <- solveCs cfg target cgi info dc donePhase Loud "solve" - let out = Just $ O (checkedNames pruned cbs'') (logWarn cgi) sol (annotMap cgi) - exitWithResult target out (result $ sinfo <$> r) + let out' = mconcat [maybe mempty DC.oldOutput dc, out] + DC.saveResult target out' + exitWithResult cfg target out' -checkedNames False _ = Nothing -checkedNames True cbs = Just $ concatMap names cbs - where - names (NonRec v _ ) = [varName v] - names (Rec bs) = map (varName . fst) bs +-- checkedNames :: Maybe DC.DiffCheck -> Maybe [Name.Name] +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 (True, DC.thin cbs vs) - | diffcheck cfg = (True,) <$> DC.slice target cbs - | otherwise = return (False, cbs) + | not (null vs) = return . Just $ DC.DC (DC.thin cbs vs) mempty + | diffcheck cfg = DC.slice target cbs + | otherwise = return Nothing where vs = tgtVars $ spec info -solveCs cfg target cgi info - | nofalse cfg - = do hqBot <- getHqBotPath - (_, solBot) <- solve fx target [hqBot] (cgInfoFInfoBot cgi) - let falseKvars = M.keys (M.filterWithKey (const isFalse) solBot) - putStrLn $ "False KVars" ++ show falseKvars - solve fx target (hqFiles info) (cgInfoFInfoKvars cgi falseKvars) - - | otherwise - = solve fx target (hqFiles info) (cgInfoFInfo cgi) - where - fx = def { solver = smtsolver cfg } +solveCs cfg target cgi info dc + = do (r, sol) <- solve fx target (hqFiles info) (cgInfoFInfo cgi) + let names = checkedNames dc + let warns = logWarn cgi + let annm = annotMap cgi + let res = ferr sol r + let out0 = mkOutput cfg res sol annm + return $ out0 { o_vars = names } { o_warns = warns} { o_result = res } + where + fx = def { FC.solver = smtsolver cfg, FC.real = real cfg } + ferr s r = fmap (tidyError s) $ result $ sinfo <$> r + writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str where - str = {-# SCC "PPcgi" #-} showFix cgi + str = {-# SCC "PPcgi" #-} showpp cgi + diff --git a/include/Control/Exception.spec b/include/Control/Exception.spec --- a/include/Control/Exception.spec +++ b/include/Control/Exception.spec @@ -1,7 +1,5 @@ module spec Control.Exception where -- Useless as compiled into GHC primitive, which is ignored -assume assert :: {v:Bool | (? (Prop v))} -> a -> a +assume assert :: {v:Bool | Prop v } -> a -> a --- Hack into wiredIn --- assume GHC.IO.Exception.assertError :: {v:Bool | (? v)} -> GHC.Prim.Addr# -> a -> a diff --git a/include/Data/Bits.spec b/include/Data/Bits.spec new file mode 100644 --- /dev/null +++ b/include/Data/Bits.spec @@ -0,0 +1,6 @@ +module spec Data.Bits where + +-- TODO: cannot use this because `Bits` is not a `Num` +-- Data.Bits.shiftR :: (Data.Bits.Bits a) => x:a -> d:Nat +-- -> {v:a | ((d=1) => (x <= 2*v + 1 && 2*v <= x)) } + diff --git a/include/Data/Either.spec b/include/Data/Either.spec new file mode 100644 --- /dev/null +++ b/include/Data/Either.spec @@ -0,0 +1,15 @@ +module spec Data.Either where + +invariant {v:[Data.Either.Either a b] | (lenRight v >= 0) && (lenRight v <= len v)} + +measure lenRight :: [Data.Either.Either a b] -> GHC.Types.Int +lenRight (x:xs) = if (isLeft x) then (lenRight xs) else (lenRight xs + 1) +lenRight ([]) = 0 + +measure isLeftHd :: [Data.Either.Either a b] -> Prop +isLeftHd (x:xs) = (isLeft x) +isLeftHd ([]) = false + +measure isLeft :: Data.Either.Either a b -> Prop +isLeft (Left x) = true +isLeft (Right x) = false diff --git a/include/Data/List.spec b/include/Data/List.spec --- a/include/Data/List.spec +++ b/include/Data/List.spec @@ -1,18 +1,21 @@ module spec Data.List where import GHC.List +import GHC.Types assume groupBy :: (a -> a -> GHC.Types.Bool) -> [a] -> [{v:[a] | len(v) > 0}] assume transpose :: [[a]] -> [{v:[a] | (len v) > 0}] -assume GHC.List.splitAt :: n:Nat -> x:[a] -> ({v:[a] | (Min (len v) (len x) n)},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}> - -assume GHC.List.concat :: x:[[a]] -> {v:[a] | (len v) = (sumLens x)} - -measure sumLens :: [[a]] -> GHC.Types.Int -sumLens ([]) = 0 -sumLens (c:cs) = (len c) + (sumLens cs) +-- assume GHC.List.concat :: x:[[a]] -> {v:[a] | (len v) = (sumLens x)} +-- +-- measure sumLens :: [[a]] -> GHC.Types.Int +-- sumLens ([]) = 0 +-- sumLens (c:cs) = (len c) + (sumLens cs) +-- +-- invariant {v:[[a]] | (sumLens v) >= 0} +-- qualif SumLensEq(v:List List a, x:List List a): (sumLens v) = (sumLens x) +-- qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x) +-- qualif SumLensLe(v:List List a, x:List List a): (sumLens v) <= (sumLens x) -qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x) diff --git a/include/Data/Set.spec b/include/Data/Set.spec --- a/include/Data/Set.spec +++ b/include/Data/Set.spec @@ -43,11 +43,12 @@ intersection :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cap xs ys)} difference :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_dif xs ys)} +fromList :: GHC.Classes.Ord a => xs:[a] -> {v:Data.Set.Set a | v = (listElts xs)} --------------------------------------------------------------------------------------------- -- | The set of elements in a list ---------------------------------------------------------- --------------------------------------------------------------------------------------------- measure listElts :: [a] -> (Data.Set.Set a) -listElts([]) = {v | (? Set_emp(v))} +listElts([]) = {v | (Set_emp v)} listElts(x:xs) = {v | v = (Set_cup (Set_sng x) (listElts xs)) } diff --git a/include/Data/Vector.spec b/include/Data/Vector.spec --- a/include/Data/Vector.spec +++ b/include/Data/Vector.spec @@ -2,12 +2,13 @@ import GHC.Base -measure vlen :: forall a. (Vector a) -> Int +measure vlen :: forall a. (Data.Vector.Vector a) -> Int +-- measure vlen :: forall a. a -> Int -invariant {v: Vector a | (vlen v) >= 0 } +invariant {v: Data.Vector.Vector a | (vlen v) >= 0 } -assume ! :: forall a. x:(Vector a) -> vec:{v: Int | ((0 <= v) && (v < (vlen x))) } -> a +assume ! :: forall a. x:(Data.Vector.Vector a) -> vec:{v: Int | ((0 <= v) && (v < (vlen x))) } -> a -assume fromList :: forall a. x:[a] -> {v: Vector a | (vlen v) = (len x) } +assume fromList :: forall a. x:[a] -> {v: Data.Vector.Vector a | (vlen v) = (len x) } -assume length :: forall a. x:(Vector a) -> {v: Int | (v = (vlen x) && v >= 0) } +assume length :: forall a. x:(Data.Vector.Vector a) -> {v: Int | (v = (vlen x) && v >= 0) } diff --git a/include/Foreign/C/Types.spec b/include/Foreign/C/Types.spec --- a/include/Foreign/C/Types.spec +++ b/include/Foreign/C/Types.spec @@ -1,8 +1,5 @@ module spec Foreign.C.Types where --- measure cSizeInt :: CSize -> GHC.Types.Int --- invariant {v: CSize | (cSizeInt v) >= 0} - embed Foreign.C.Types.CInt as int embed Foreign.C.Types.CSize as int embed Foreign.C.Types.CULong as int diff --git a/include/Foreign/ForeignPtr.spec b/include/Foreign/ForeignPtr.spec --- a/include/Foreign/ForeignPtr.spec +++ b/include/Foreign/ForeignPtr.spec @@ -3,13 +3,6 @@ import GHC.ForeignPtr import Foreign.Ptr -measure fplen :: GHC.ForeignPtr.ForeignPtr a -> GHC.Types.Int - -type ForeignPtrV a = {v: (GHC.ForeignPtr.ForeignPtr a) | 0 <= (fplen v)} - -type ForeignPtrN a N = {v: (ForeignPtrV a) | (fplen v) = N } - - Foreign.ForeignPtr.withForeignPtr :: fp:(GHC.ForeignPtr.ForeignPtr a) -> ((PtrN a (fplen fp)) -> GHC.Types.IO b) -> (GHC.Types.IO b) GHC.ForeignPtr.newForeignPtr_ :: p:(GHC.Ptr.Ptr a) -> (GHC.Types.IO (ForeignPtrN a (plen p))) Foreign.Concurrent.newForeignPtr :: p:(PtrV a) -> GHC.Types.IO () -> (GHC.Types.IO (ForeignPtrN a (plen p))) diff --git a/include/Foreign/Ptr.spec b/include/Foreign/Ptr.spec --- a/include/Foreign/Ptr.spec +++ b/include/Foreign/Ptr.spec @@ -2,9 +2,4 @@ import GHC.Ptr -measure pbase :: Foreign.Ptr.Ptr a -> GHC.Types.Int -measure plen :: Foreign.Ptr.Ptr a -> GHC.Types.Int -measure isNullPtr :: Foreign.Ptr.Ptr a -> Prop -type PtrN a N = {v: (PtrV a) | (plen v) = N } -type PtrV a = {v: (GHC.Ptr.Ptr a) | 0 <= (plen v) } diff --git a/include/Foreign/Storable.spec b/include/Foreign/Storable.spec --- a/include/Foreign/Storable.spec +++ b/include/Foreign/Storable.spec @@ -1,14 +1,18 @@ module spec Foreign.Storable where +import Foreign.Ptr +-- DON'T do this, we can't import HS files from SPEC files +-- import Language.Haskell.Liquid.Foreign + predicate PValid P N = ((0 <= N) && (N < (plen P))) Foreign.Storable.poke :: (Foreign.Storable.Storable a) - => {v: (GHC.Ptr.Ptr a) | 0 <= (plen v)} + => {v: (GHC.Ptr.Ptr a) | 0 < (plen v)} -> a -> (GHC.Types.IO ()) Foreign.Storable.peek :: (Foreign.Storable.Storable a) - => p:{v: (GHC.Ptr.Ptr a) | 0 <= (plen v)} + => p:{v: (GHC.Ptr.Ptr a) | 0 < (plen v)} -> (GHC.Types.IO {v:a | v = (deref p)}) Foreign.Storable.peekByteOff :: (Foreign.Storable.Storable a) diff --git a/include/GHC/Base.spec b/include/GHC/Base.spec --- a/include/GHC/Base.spec +++ b/include/GHC/Base.spec @@ -3,7 +3,6 @@ import GHC.Prim import GHC.Classes import GHC.Types -import GHC.Err embed GHC.Types.Int as int embed Prop as bool @@ -24,10 +23,11 @@ measure snd :: (a,b) -> b snd (a,b) = b -invariant {v: [a] | len(v) >= 0 } -assume map :: (x:a -> b) -> xs:[a] -> {v: [b] | len(v) = len(xs)} +invariant {v: [a] | len(v) >= 0 } +map :: (a -> b) -> xs:[a] -> {v: [b] | len(v) = len(xs)} +(++) :: xs:[a] -> ys:[a] -> {v:[a] | (len v) = (len xs) + (len ys)} -assume $ :: (x:a -> b) -> a -> b -assume id :: x:a -> {v:a | v = x} +$ :: (a -> b) -> a -> b +id :: x:a -> {v:a | v = x} diff --git a/include/GHC/Classes.spec b/include/GHC/Classes.spec --- a/include/GHC/Classes.spec +++ b/include/GHC/Classes.spec @@ -25,5 +25,5 @@ ((v = GHC.Types.LT) <=> (x < y)) && ((v = GHC.Types.GT) <=> (x > y))) } -max :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = ((x > y) ? x : y) } -min :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = ((x < y) ? x : y) } +max :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x > y then x else y) } +min :: (GHC.Classes.Ord a) => x:a -> y:a -> {v:a | v = (if x < y then x else y) } diff --git a/include/GHC/ForeignPtr.spec b/include/GHC/ForeignPtr.spec --- a/include/GHC/ForeignPtr.spec +++ b/include/GHC/ForeignPtr.spec @@ -1,4 +1,9 @@ module spec GHC.ForeignPtr where +measure fplen :: GHC.ForeignPtr.ForeignPtr a -> GHC.Types.Int + +type ForeignPtrV a = {v: (GHC.ForeignPtr.ForeignPtr a) | 0 <= (fplen v)} +type ForeignPtrN a N = {v: (ForeignPtrV a) | (fplen v) = N } + mallocPlainForeignPtrBytes :: n:{v:GHC.Types.Int | v >= 0 } -> (GHC.Types.IO (ForeignPtrN a n)) diff --git a/include/GHC/Int.spec b/include/GHC/Int.spec --- a/include/GHC/Int.spec +++ b/include/GHC/Int.spec @@ -1,5 +1,7 @@ module spec GHC.Int where +embed GHC.Int.Int8 as int +embed GHC.Int.Int16 as int embed GHC.Int.Int32 as int embed GHC.Int.Int64 as int diff --git a/include/GHC/List.lhs b/include/GHC/List.lhs deleted file mode 100644 --- a/include/GHC/List.lhs +++ /dev/null @@ -1,790 +0,0 @@ -\begin{code} - -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} -{-# OPTIONS_HADDOCK hide #-} - ------------------------------------------------------------------------------ --- | --- Module : GHC.List --- Copyright : (c) The University of Glasgow 1994-2002 --- License : see libraries/base/LICENSE --- --- Maintainer : cvs-ghc@haskell.org --- Stability : internal --- Portability : non-portable (GHC Extensions) --- --- The List data type and its operations --- ------------------------------------------------------------------------------ - --- #hide -module GHC.List ( - -- [] (..), -- Not Haskell 98; built in syntax - - map, (++), filter, concat, - head, last, tail, init, null, length, (!!), - foldl, scanl, scanl1, foldr, foldr1, scanr, scanr1, - iterate, repeat, replicate, cycle, - take, drop, splitAt, takeWhile, dropWhile, span, break, - reverse, and, or, - any, all, elem, notElem, lookup, - concatMap, - zip, zip3, zipWith, zipWith3, unzip, unzip3, - errorEmptyList, - -#ifndef USE_REPORT_PRELUDE - -- non-standard, but hidden when creating the Prelude - -- export list. - takeUInt_append -#endif - - ) where - -import Data.Maybe -import GHC.Base -import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError) - -infixl 9 !! -infix 4 `elem`, `notElem` - - -\end{code} - -%********************************************************* -%* * -\subsection{List-manipulation functions} -%* * -%********************************************************* - -\begin{code} --- | Extract the first element of a list, which must be non-empty. -{-@ assert head :: xs:{v: [a] | len(v) > 0} -> a @-} -head :: [a] -> a -head (x:_) = x -head [] = errorEmptyList "head" - -badHead :: a -badHead = error "errorEmptyList head" -- errorEmptyList "head" - --- This rule is useful in cases like --- head [y | (x,y) <- ps, x==t] -{-# RULES -"head/build" forall (g::forall b.(a->b->b)->b->b) . - head (build g) = g (\x _ -> x) badHead -"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) . - head (augment g xs) = g (\x _ -> x) (head xs) - #-} - --- | Extract the elements after the head of a list, which must be non-empty. -{-@ assert tail :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = (len(xs) - 1)} @-} -tail :: [a] -> [a] -tail (_:xs) = xs -tail [] = liquidError "tail" -- errorEmptyList "tail" - --- | Extract the last element of a list, which must be finite and non-empty. -{-@ assert last :: xs:{v: [a] | len(v) > 0} -> a @-} -last :: [a] -> a -#ifdef USE_REPORT_PRELUDE -last [x] = x -last (_:xs) = last xs -last [] = liquidError "last" -- errorEmptyList "last" -#else --- eliminate repeated cases -last [] = liquidError "last" -- errorEmptyList "last" -last (x:xs) = last' x xs - where last' y [] = y - last' _ (y:ys) = last' y ys -#endif - --- | Return all the elements of a list except the last one. --- The list must be non-empty. -{-@ assert init :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) - 1} @-} -init :: [a] -> [a] -#ifdef USE_REPORT_PRELUDE -init [x] = [] -init (x:xs) = x : init xs -init [] = liquidError "init" -- errorEmptyList "init" -#else --- eliminate repeated cases -init [] = liquidError "init" --errorEmptyList "init" -init (x:xs) = init' x xs - where init' _ [] = [] - init' y (z:zs) = y : init' z zs -#endif - --- | Test whether a list is empty. -{-@ assert null :: xs:[a] -> {v: Bool | (Prop(v) <=> len(xs) = 0) } @-} -null :: [a] -> Bool -null [] = True -null (_:_) = False - --- | /O(n)/. 'length' returns the length of a finite list as an 'Int'. --- It is an instance of the more general 'Data.List.genericLength', --- the result type of which may be any kind of number. -{-@ assert length :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)} @-} -length :: [a] -> Int -length l = len l 0# - where - --LIQUID FIXME: leaving the type signature causes this to compile to very strange core - --LIQUID len :: [a] -> Int# -> Int - len [] a# = I# a# - len (_:xs) a# = len xs (a# +# 1#) - --- | 'filter', applied to a predicate and a list, returns the list of --- those elements that satisfy the predicate; i.e., --- --- > filter p xs = [ x | x <- xs, p x] - -{-@ assert filter :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-} -filter :: (a -> Bool) -> [a] -> [a] -filter _pred [] = [] -filter pred (x:xs) - | pred x = x : filter pred xs - | otherwise = filter pred xs - -{-# NOINLINE [0] filterFB #-} -filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b -filterFB c p x r | p x = x `c` r - | otherwise = r - -{-# RULES -"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) -"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p -"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) - #-} - --- Note the filterFB rule, which has p and q the "wrong way round" in the RHS. --- filterFB (filterFB c p) q a b --- = if q a then filterFB c p a b else b --- = if q a then (if p a then c a b else b) else b --- = if q a && p a then c a b else b --- = filterFB c (\x -> q x && p x) a b --- I originally wrote (\x -> p x && q x), which is wrong, and actually --- gave rise to a live bug report. SLPJ. - - --- | 'foldl', applied to a binary operator, a starting value (typically --- the left-identity of the operator), and a list, reduces the list --- using the binary operator, from left to right: --- --- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn --- --- The list must be finite. - --- We write foldl as a non-recursive thing, so that it --- can be inlined, and then (often) strictness-analysed, --- and hence the classic space leak on foldl (+) 0 xs - -foldl :: (a -> b -> a) -> a -> [b] -> a -foldl f z0 xs0 = lgo z0 xs0 - where - --LIQUID FIXME: lgo takes 5 parameters once compiled to core - {-@ Decrease lgo 5 @-} - lgo z [] = z - lgo z (x:xs) = lgo (f z x) xs - --- | 'scanl' is similar to 'foldl', but returns a list of successive --- reduced values from the left: --- --- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] --- --- Note that --- --- > last (scanl f z xs) == foldl f z xs. -{-@ assert scanl :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) } @-} -scanl :: (a -> b -> a) -> a -> [b] -> [a] -scanl f q ls = q : (case ls of - [] -> [] - x:xs -> scanl f (f q x) xs) - --- | 'scanl1' is a variant of 'scanl' that has no starting value argument: --- --- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] - -{-@ assert scanl1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } @-} -scanl1 :: (a -> a -> a) -> [a] -> [a] -scanl1 f (x:xs) = scanl f x xs -scanl1 _ [] = [] - --- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the --- above functions. - --- | 'foldr1' is a variant of 'foldr' that has no starting value argument, --- and thus must be applied to non-empty lists. - -{-@ assert foldr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> a @-} -foldr1 :: (a -> a -> a) -> [a] -> a -foldr1 _ [x] = x -foldr1 f (x:xs@(_:_)) = f x (foldr1 f xs) -foldr1 _ [] = liquidError "foldr1" -- errorEmptyList "foldr1" - --- | 'scanr' is the right-to-left dual of 'scanl'. --- Note that --- --- > head (scanr f z xs) == foldr f z xs. - -{-@ assert scanr :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) } @-} -scanr :: (a -> b -> b) -> b -> [a] -> [b] -scanr _ q0 [] = [q0] -scanr f q0 (x:xs) = f x q : qs - where qs@(q:_) = scanr f q0 xs - --- | 'scanr1' is a variant of 'scanr' that has no starting value argument. - -{-@ assert scanr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } @-} -scanr1 :: (a -> a -> a) -> [a] -> [a] -scanr1 _ [] = [] -scanr1 _ [x] = [x] -scanr1 f (x:xs@(_:_)) = f x q : qs - where qs@(q:_) = scanr1 f xs - --- | 'iterate' @f x@ returns an infinite list of repeated applications --- of @f@ to @x@: --- --- > iterate f x == [x, f x, f (f x), ...] - -{-@ Strict GHC.List.iterate @-} -iterate :: (a -> a) -> a -> [a] -iterate f x = x : iterate f (f x) - -{-@ Strict GHC.List.iterateFB @-} -iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b -iterateFB c f x = x `c` iterateFB c f (f x) - - -{-# RULES -"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x) -"iterateFB" [1] iterateFB (:) = iterate - #-} - - --- | 'repeat' @x@ is an infinite list, with @x@ the value of every element. -{-@ Strict GHC.List.repeat @-} -repeat :: a -> [a] -{-# INLINE [0] repeat #-} --- The pragma just gives the rules more chance to fire -repeat x = xs where xs = x : xs - -{-# INLINE [0] repeatFB #-} -- ditto -{-@ Strict GHC.List.repeatFB @-} -repeatFB :: (a -> b -> b) -> a -> b -repeatFB c x = xs where xs = x `c` xs - - -{-# RULES -"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x) -"repeatFB" [1] repeatFB (:) = repeat - #-} - --- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of --- every element. --- It is an instance of the more general 'Data.List.genericReplicate', --- in which @n@ may be of any integral type. -{-# INLINE replicate #-} -{-@ assert replicate :: n:GHC.Types.Int -> x:a -> {v: [{v:a | v = x}] | len(v) = n} @-} -replicate :: Int -> a -> [a] -replicate n x = take n (repeat x) - --- | 'cycle' ties a finite list into a circular one, or equivalently, --- the infinite repetition of the original list. It is the identity --- on infinite lists. - -{-@ assert cycle :: {v: [a] | len(v) > 0 } -> [a] @-} -{-@ Strict GHC.List.cycle @-} -cycle :: [a] -> [a] -cycle [] = liquidError {- error -} "Prelude.cycle: empty list" -cycle xs = xs' where xs' = xs ++ xs' - --- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the --- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@: --- --- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2] --- > takeWhile (< 9) [1,2,3] == [1,2,3] --- > takeWhile (< 0) [1,2,3] == [] --- - -{-@ assert takeWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-} -takeWhile :: (a -> Bool) -> [a] -> [a] -takeWhile _ [] = [] -takeWhile p (x:xs) - | p x = x : takeWhile p xs - | otherwise = [] - --- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@: --- --- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3] --- > dropWhile (< 9) [1,2,3] == [] --- > dropWhile (< 0) [1,2,3] == [1,2,3] --- - -{-@ assert dropWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} @-} -dropWhile :: (a -> Bool) -> [a] -> [a] -dropWhile _ [] = [] -dropWhile p xs@(x:xs') - | p x = dropWhile p xs' - | otherwise = xs - --- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@ --- of length @n@, or @xs@ itself if @n > 'length' xs@: --- --- > take 5 "Hello World!" == "Hello" --- > take 3 [1,2,3,4,5] == [1,2,3] --- > take 3 [1,2] == [1,2] --- > take 3 [] == [] --- > take (-1) [1,2] == [] --- > take 0 [1,2] == [] --- --- It is an instance of the more general 'Data.List.genericTake', --- in which @n@ may be of any integral type. - - -{-@ assert take :: n: {v: Int | v >= 0 } -> xs:[a] -> {v:[a] | len(v) = ((len(xs) < n) ? len(xs) : n) } @-} -take :: Int -> [a] -> [a] - --- | 'drop' @n xs@ returns the suffix of @xs@ --- after the first @n@ elements, or @[]@ if @n > 'length' xs@: --- --- > drop 6 "Hello World!" == "World!" --- > drop 3 [1,2,3,4,5] == [4,5] --- > drop 3 [1,2] == [] --- > drop 3 [] == [] --- > drop (-1) [1,2] == [1,2] --- > drop 0 [1,2] == [1,2] --- --- It is an instance of the more general 'Data.List.genericDrop', --- in which @n@ may be of any integral type. -{-@ assert drop :: n: {v: Int | v >= 0 } -> xs:[a] -> {v:[a] | len(v) = ((len(xs) < n) ? 0 : len(xs) - n) } @-} -drop :: Int -> [a] -> [a] - --- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of --- length @n@ and second element is the remainder of the list: --- --- > splitAt 6 "Hello World!" == ("Hello ","World!") --- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5]) --- > splitAt 1 [1,2,3] == ([1],[2,3]) --- > splitAt 3 [1,2,3] == ([1,2,3],[]) --- > splitAt 4 [1,2,3] == ([1,2,3],[]) --- > splitAt 0 [1,2,3] == ([],[1,2,3]) --- > splitAt (-1) [1,2,3] == ([],[1,2,3]) --- --- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@ --- (@splitAt _|_ xs = _|_@). --- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt', --- in which @n@ may be of any integral type. --- Liquid: TODO -splitAt :: Int -> [a] -> ([a],[a]) - -#ifdef USE_REPORT_PRELUDE -take n _ | n <= 0 = [] -take _ [] = [] -take n (x:xs) = x : take (n-1) xs - -drop n xs | n <= 0 = xs -drop _ [] = [] -drop n (_:xs) = drop (n-1) xs - -splitAt n xs = (take n xs, drop n xs) - -#else /* hack away */ -{-# RULES -"take" [~1] forall n xs . take n xs = takeFoldr n xs -"takeList" [1] forall n xs . foldr (takeFB (:) []) (takeConst []) xs n = takeUInt n xs - #-} - -{-# INLINE takeFoldr #-} -takeFoldr :: Int -> [a] -> [a] -takeFoldr (I# n#) xs - = build (\c nil -> if n# <=# 0# then nil else - foldr (takeFB c nil) (takeConst nil) xs n#) - -{-# NOINLINE [0] takeConst #-} --- just a version of const that doesn't get inlined too early, so we --- can spot it in rules. Also we need a type sig due to the unboxed Int#. -takeConst :: a -> Int# -> a -takeConst x _ = x - -{-# NOINLINE [0] takeFB #-} -takeFB :: (a -> b -> b) -> b -> a -> (Int# -> b) -> Int# -> b -takeFB c n x xs m | m <=# 1# = x `c` n - | otherwise = x `c` xs (m -# 1#) - -{-- INLINE [0] take #-} -take (I# n#) xs = takeUInt n# xs - --- The general code for take, below, checks n <= maxInt --- No need to check for maxInt overflow when specialised --- at type Int or Int# since the Int must be <= maxInt - -takeUInt :: Int# -> [b] -> [b] -takeUInt n xs - | n >=# 0# = take_unsafe_UInt n xs - | otherwise = liquidAssert False [] - -take_unsafe_UInt :: Int# -> [b] -> [b] -take_unsafe_UInt 0# _ = [] -take_unsafe_UInt m ls = - case ls of - [] -> [] - (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs - -takeUInt_append :: Int# -> [b] -> [b] -> [b] -takeUInt_append n xs rs - | n >=# 0# = take_unsafe_UInt_append n xs rs - | otherwise = [] - -take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b] -take_unsafe_UInt_append 0# _ rs = rs -take_unsafe_UInt_append m ls rs = - case ls of - [] -> rs - (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs - -drop (I# n#) ls - | n# <# 0# = ls - | otherwise = drop# n# ls - where - drop# :: Int# -> [a] -> [a] - drop# 0# xs = xs - drop# _ xs@[] = xs - drop# m# (_:xs) = drop# (m# -# 1#) xs - -splitAt (I# n#) ls - | n# <# 0# = ([], ls) - | otherwise = splitAt# n# ls - where - splitAt# :: Int# -> [a] -> ([a], [a]) - splitAt# 0# xs = ([], xs) - splitAt# _ xs@[] = (xs, xs) - splitAt# m# (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt# (m# -# 1#) xs - -#endif /* USE_REPORT_PRELUDE */ - --- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where --- first element is longest prefix (possibly empty) of @xs@ of elements that --- satisfy @p@ and second element is the remainder of the list: --- --- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4]) --- > span (< 9) [1,2,3] == ([1,2,3],[]) --- > span (< 0) [1,2,3] == ([],[1,2,3]) --- --- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@ --- Liquid: TODO -{-@ -span :: (a -> Bool) - -> xs:[a] - -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))}) -@-} -span :: (a -> Bool) -> [a] -> ([a], [a]) -span _ xs@[] = (xs, xs) -span p xs@(x:xs') - | p x = let (ys,zs) = span p xs' in (x:ys,zs) - | otherwise = ([],xs) - --- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where --- first element is longest prefix (possibly empty) of @xs@ of elements that --- /do not satisfy/ @p@ and second element is the remainder of the list: --- --- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4]) --- > break (< 9) [1,2,3] == ([],[1,2,3]) --- > break (> 9) [1,2,3] == ([1,2,3],[]) --- --- 'break' @p@ is equivalent to @'span' ('not' . p)@. --- liquid:TODO -break :: (a -> Bool) -> [a] -> ([a],[a]) -#ifdef USE_REPORT_PRELUDE -break p = span (not . p) -#else --- HBC version (stolen) -break _ xs@[] = (xs, xs) -break p xs@(x:xs') - | p x = ([],xs) - | otherwise = let (ys,zs) = break p xs' in (x:ys,zs) -#endif - --- | 'reverse' @xs@ returns the elements of @xs@ in reverse order. --- @xs@ must be finite. -{-@ assert reverse :: xs:[a] -> {v: [a] | len(v) = len(xs)} @-} -{-@ include @-} -reverse :: [a] -> [a] -#ifdef USE_REPORT_PRELUDE -reverse = foldl (flip (:)) [] -#else -reverse l = rev l [] - where - rev [] a = a - rev (x:xs) a = rev xs (x:a) -#endif - --- | 'and' returns the conjunction of a Boolean list. For the result to be --- 'True', the list must be finite; 'False', however, results from a 'False' --- value at a finite index of a finite or infinite list. -and :: [Bool] -> Bool - --- | 'or' returns the disjunction of a Boolean list. For the result to be --- 'False', the list must be finite; 'True', however, results from a 'True' --- value at a finite index of a finite or infinite list. -or :: [Bool] -> Bool -#ifdef USE_REPORT_PRELUDE -and = foldr (&&) True -or = foldr (||) False -#else -and [] = True -and (x:xs) = x && and xs -or [] = False -or (x:xs) = x || or xs - -{-# RULES -"and/build" forall (g::forall b.(Bool->b->b)->b->b) . - and (build g) = g (&&) True -"or/build" forall (g::forall b.(Bool->b->b)->b->b) . - or (build g) = g (||) False - #-} -#endif - --- | Applied to a predicate and a list, 'any' determines if any element --- of the list satisfies the predicate. For the result to be --- 'False', the list must be finite; 'True', however, results from a 'True' --- value for the predicate applied to an element at a finite index of a finite or infinite list. -any :: (a -> Bool) -> [a] -> Bool - --- | Applied to a predicate and a list, 'all' determines if all elements --- of the list satisfy the predicate. For the result to be --- 'True', the list must be finite; 'False', however, results from a 'False' --- value for the predicate applied to an element at a finite index of a finite or infinite list. -all :: (a -> Bool) -> [a] -> Bool -#ifdef USE_REPORT_PRELUDE -any p = or . map p -all p = and . map p -#else -any _ [] = False -any p (x:xs) = p x || any p xs - -all _ [] = True -all p (x:xs) = p x && all p xs -{-# RULES -"any/build" forall p (g::forall b.(a->b->b)->b->b) . - any p (build g) = g ((||) . p) False -"all/build" forall p (g::forall b.(a->b->b)->b->b) . - all p (build g) = g ((&&) . p) True - #-} -#endif - --- | 'elem' is the list membership predicate, usually written in infix form, --- e.g., @x \`elem\` xs@. For the result to be --- 'False', the list must be finite; 'True', however, results from an element equal to @x@ found at a finite index of a finite or infinite list. -elem :: (Eq a) => a -> [a] -> Bool - --- | 'notElem' is the negation of 'elem'. -notElem :: (Eq a) => a -> [a] -> Bool -#ifdef USE_REPORT_PRELUDE -elem x = any (== x) -notElem x = all (/= x) -#else -elem _ [] = False -elem x (y:ys) = x==y || elem x ys - -notElem _ [] = True -notElem x (y:ys)= x /= y && notElem x ys -#endif - --- | 'lookup' @key assocs@ looks up a key in an association list. -lookup :: (Eq a) => a -> [(a,b)] -> Maybe b -lookup _key [] = Nothing -lookup key ((x,y):xys) - | key == x = Just y - | otherwise = lookup key xys - --- | Map a function over a list and concatenate the results. -concatMap :: (a -> [b]) -> [a] -> [b] -concatMap f = foldr ((++) . f) [] - --- | Concatenate a list of lists. -concat :: [[a]] -> [a] -concat = foldr (++) [] - -{-# RULES - "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) --- We don't bother to turn non-fusible applications of concat back into concat - #-} - -\end{code} - - -\begin{code} --- | List index (subscript) operator, starting from 0. --- It is an instance of the more general 'Data.List.genericIndex', --- which takes an index of any integral type. - -{-@ assert GHC.List.!! :: xs:[a] -> {v: Int | ((0 <= v) && (v < len(xs)))} -> a @-} -(!!) :: [a] -> Int -> a -#ifdef USE_REPORT_PRELUDE -xs !! n | n < 0 = liquidError {- error -} "Prelude.!!: negative index" -[] !! _ = liquidError {- error -} "Prelude.!!: index too large" -(x:_) !! 0 = x -(_:xs) !! n = xs !! (n-1) -#else --- HBC version (stolen), then unboxified --- The semantics is not quite the same for error conditions --- in the more efficient version. --- -xs !! (I# n0) | n0 <# 0# = liquidError {- error -} "Prelude.(!!): negative index\n" - | otherwise = sub xs n0 - where - sub :: [a] -> Int# -> a - sub [] _ = liquidError {- error -} "Prelude.(!!): index too large\n" - sub (y:ys) n = if n ==# 0# - then y - else sub ys (n -# 1#) -#endif -\end{code} - - -%********************************************************* -%* * -\subsection{The zip family} -%* * -%********************************************************* - -\begin{code} -foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c -foldr2 _k z [] _ys = z -foldr2 _k z _xs [] = z -foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys) - -foldr2_left :: (a -> b -> c -> d) -> d -> a -> ([b] -> c) -> [b] -> d -foldr2_left _k z _x _r [] = z -foldr2_left k _z x r (y:ys) = k x y (r ys) - -foldr2_right :: (a -> b -> c -> d) -> d -> b -> ([a] -> c) -> [a] -> d -foldr2_right _k z _y _r [] = z -foldr2_right k _z y r (x:xs) = k x y (r xs) - --- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys --- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs -{-# RULES -"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) . - foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys - -"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) . - foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs - #-} -\end{code} - -The foldr2/right rule isn't exactly right, because it changes -the strictness of foldr2 (and thereby zip) - -E.g. main = print (null (zip nonobviousNil (build undefined))) - where nonobviousNil = f 3 - f n = if n == 0 then [] else f (n-1) - -I'm going to leave it though. - - -Zips for larger tuples are in the List module. - -\begin{code} ----------------------------------------------- --- | 'zip' takes two lists and returns a list of corresponding pairs. --- If one input list is short, excess elements of the longer list are --- discarded. -zip :: [a] -> [b] -> [(a,b)] -zip (a:as) (b:bs) = (a,b) : zip as bs -zip _ _ = [] - -{-# INLINE [0] zipFB #-} -zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d -zipFB c = \x y r -> (x,y) `c` r - -{-# RULES -"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) -"zipList" [1] foldr2 (zipFB (:)) [] = zip - #-} -\end{code} - -\begin{code} ----------------------------------------------- --- | 'zip3' takes three lists and returns a list of triples, analogous to --- 'zip'. -zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] --- Specification --- zip3 = zipWith3 (,,) -zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs -zip3 _ _ _ = [] -\end{code} - - --- The zipWith family generalises the zip family by zipping with the --- function given as the first argument, instead of a tupling function. - -\begin{code} ----------------------------------------------- --- | 'zipWith' generalises 'zip' by zipping with the function given --- as the first argument, instead of a tupling function. --- For example, @'zipWith' (+)@ is applied to two lists to produce the --- list of corresponding sums. - - -{-@ zipWith :: (a -> b -> c) - -> xs : [a] -> ys:[b] - -> {v : [c] | (((len v) <= (len xs)) && ((len v) <= (len ys)))} @-} -zipWith :: (a->b->c) -> [a]->[b]->[c] -zipWith f (a:as) (b:bs) = f a b : zipWith f as bs -zipWith _ _ _ = [] - --- zipWithFB must have arity 2 since it gets two arguments in the "zipWith" --- rule; it might not get inlined otherwise -{-# INLINE [0] zipWithFB #-} -zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c -zipWithFB c f = \x y r -> (x `f` y) `c` r - -{-# RULES -"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) -"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f - #-} -\end{code} - -\begin{code} --- | The 'zipWith3' function takes a function which combines three --- elements, as well as three lists and returns a list of their point-wise --- combination, analogous to 'zipWith'. -zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith3 z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3 z as bs cs -zipWith3 _ _ _ _ = [] - --- | 'unzip' transforms a list of pairs into a list of first components --- and a list of second components. -unzip :: [(a,b)] -> ([a],[b]) -{-# INLINE unzip #-} -unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) - --- | The 'unzip3' function takes a list of triples and returns three --- lists, analogous to 'unzip'. -unzip3 :: [(a,b,c)] -> ([a],[b],[c]) -{-# INLINE unzip3 #-} -unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) - ([],[],[]) -\end{code} - - -%********************************************************* -%* * -\subsection{Error code} -%* * -%********************************************************* - -Common up near identical calls to `error' to reduce the number -constant strings created when compiled: - -\begin{code} -{-@ assert errorEmptyList :: {v: String | (0 = 1)} -> a @-} -errorEmptyList :: String -> a -errorEmptyList fun = - liquidError {- error -} (prel_list_str ++ fun ++ ": empty list") - -prel_list_str :: String -prel_list_str = "Prelude." -\end{code} diff --git a/include/GHC/List.spec b/include/GHC/List.spec new file mode 100644 --- /dev/null +++ b/include/GHC/List.spec @@ -0,0 +1,62 @@ +module spec GHC.List where + +head :: xs:{v: [a] | len(v) > 0} -> a + +tail :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = (len(xs) - 1)} +last :: xs:{v: [a] | len(v) > 0} -> a + +init :: xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) - 1} +null :: xs:[a] -> {v: Bool | (Prop(v) <=> len(xs) = 0) } +length :: xs:[a] -> {v: GHC.Types.Int | v = len(xs)} +filter :: (a -> GHC.Types.Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} +scanl :: (a -> b -> a) -> a -> xs:[b] -> {v: [a] | len(v) = 1 + len(xs) } +scanl1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } +foldr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> a +scanr :: (a -> b -> b) -> b -> xs:[a] -> {v: [b] | len(v) = 1 + len(xs) } +scanr1 :: (a -> a -> a) -> xs:{v: [a] | len(v) > 0} -> {v: [a] | len(v) = len(xs) } + +Lazy GHC.List.iterate +iterate :: (a -> a) -> a -> [a] + +repeat :: a -> [a] +Lazy GHC.List.repeat + +replicate :: n:Nat -> x:a -> {v: [{v:a | v = x}] | len(v) = n} + +cycle :: {v: [a] | len(v) > 0 } -> [a] +Lazy cycle + +takeWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} + +dropWhile :: (a -> Bool) -> xs:[a] -> {v: [a] | len(v) <= len(xs)} + +take :: n:GHC.Types.Int + -> xs:[a] + -> {v:[a] | if n >= 0 then (len v = (if (len xs) < n then (len xs) else n)) else (len v = 0)} +drop :: n:GHC.Types.Int + -> xs:[a] + -> {v:[a] | (if (n >= 0) then (len(v) = (if (len(xs) < n) then 0 else len(xs) - n)) else ((len v) = (len xs)))} + +splitAt :: n:_ -> x:[a] -> ({v:[a] | (if (n >= 0) then (Min (len v) (len x) n) else ((len v) = 0))},[a])<{\x1 x2 -> (len x2) = (len x) - (len x1)}> +span :: (a -> Bool) + -> xs:[a] + -> ({v:[a]|((len v)<=(len xs))}, {v:[a]|((len v)<=(len xs))}) + +break :: (a -> Bool) -> xs:[a] -> ([a],[a])<{\x y -> (len xs) = (len x) + (len y)}> + +reverse :: xs:[a] -> {v: [a] | len(v) = len(xs)} + +include + +GHC.List.!! :: xs:[a] -> {v: _ | ((0 <= v) && (v < len(xs)))} -> a + + + zip :: xs : [a] -> ys:[b] + -> {v : [(a, b)] | ((((len v) <= (len xs)) && ((len v) <= (len ys))) + && (((len xs) = (len ys)) => ((len v) = (len xs))) )} + +zipWith :: (a -> b -> c) + -> xs : [a] -> ys:[b] + -> {v : [c] | (((len v) <= (len xs)) && ((len v) <= (len ys)))} + +errorEmptyList :: {v: _ | false} -> a diff --git a/include/GHC/Prim.spec b/include/GHC/Prim.spec --- a/include/GHC/Prim.spec +++ b/include/GHC/Prim.spec @@ -1,16 +1,24 @@ module spec GHC.Prim where embed GHC.Prim.Int# as int +embed GHC.Prim.Word# as int embed GHC.Prim.Addr# as int +embed GHC.Prim.Double# as real + measure addrLen :: GHC.Prim.Addr# -> GHC.Types.Int assume GHC.Types.I# :: x:GHC.Prim.Int# -> {v: GHC.Types.Int | v = (x :: int) } assume GHC.Prim.+# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x + y} assume GHC.Prim.-# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v: GHC.Prim.Int# | v = x - y} -assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x = y)} -assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x >= y)} -assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x <= y)} -assume GHC.Prim.<# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x < y)} -assume GHC.Prim.># :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# -> {v:GHC.Types.Bool | (Prop(v) <=> x > y)} +assume GHC.Prim.==# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# + -> {v:GHC.Prim.Int# | ((v = 1) <=> x = y)} +assume GHC.Prim.>=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# + -> {v:GHC.Prim.Int# | ((v = 1) <=> x >= y)} +assume GHC.Prim.<=# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# + -> {v:GHC.Prim.Int# | ((v = 1) <=> x <= y)} +assume GHC.Prim.<# :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# + -> {v:GHC.Prim.Int# | ((v = 1) <=> x < y)} +assume GHC.Prim.># :: x:GHC.Prim.Int# -> y:GHC.Prim.Int# + -> {v:GHC.Prim.Int# | ((v = 1) <=> x > y)} diff --git a/include/GHC/Ptr.spec b/include/GHC/Ptr.spec --- a/include/GHC/Ptr.spec +++ b/include/GHC/Ptr.spec @@ -1,5 +1,12 @@ module spec GHC.Ptr where +measure pbase :: Foreign.Ptr.Ptr a -> GHC.Types.Int +measure plen :: Foreign.Ptr.Ptr a -> GHC.Types.Int +measure isNullPtr :: Foreign.Ptr.Ptr a -> Prop + +type PtrN a N = {v: (PtrV a) | (plen v) = N } +type PtrV a = {v: (GHC.Ptr.Ptr a) | 0 <= (plen v) } + GHC.Ptr.castPtr :: p:(PtrV a) -> (PtrN b (plen p)) GHC.Ptr.plusPtr :: base:(PtrV a) diff --git a/include/GHC/Read.spec b/include/GHC/Read.spec new file mode 100644 --- /dev/null +++ b/include/GHC/Read.spec @@ -0,0 +1,5 @@ +module spec GHC.Read where + +type ParsedString XS = {v:_ | (if ((len XS) > 0) then ((len v) < (len XS)) else ((len v) = 0))} + +GHC.Read.lex :: xs:_ -> [((ParsedString xs), (ParsedString xs))] diff --git a/include/GHC/Real.spec b/include/GHC/Real.spec --- a/include/GHC/Real.spec +++ b/include/GHC/Real.spec @@ -1,13 +1,22 @@ module spec GHC.Real where -GHC.Real.div :: (GHC.Real.Integral a) => x:a -> y:a -> {v:a | ((v = (x / y)) && (((x>=0) && (y>=0)) => (v>=0)) && (((x>=0) && (y>=1)) => (v<=x))) } -GHC.Real.quotRem :: (GHC.Real.Integral a) => x:a -> y:a -> ({v:a | ((v = (x / y)) && (((x>=0) && (y>=0)) => (v>=0)) && (((x>=0) && (y>=1)) => (v<=x)))} - ,{v:a | ((v >= 0) && (v < y))}) --- fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here --- GHC.Real.mod :: (Integral a) => x:a -> y:a -> {v:a | v = (x mod y) } -GHC.Real./ :: (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0} -> {v: a | v = (x / y) } - -GHC.Real.toInteger :: (GHC.Real.Integral a) => x:a -> {v:GHC.Integer.Type.Integer | v = x} GHC.Real.fromIntegral :: (GHC.Real.Integral a, GHC.Num.Num b) => x:a -> {v:b|v=x} + +class (GHC.Real.Real a, GHC.Enum.Enum a) => GHC.Real.Integral a where + GHC.Real.quot :: a -> a -> a + GHC.Real.rem :: a -> a -> a + GHC.Real.mod :: x:a -> y:a -> {v:a | v = x mod y && ((0 <= x && 0 < y) => (0 <= v && v < y))} + GHC.Real.div :: x:a -> y:a -> {v:a | ((v = (x / y)) + && (((x>=0) && (y>=0)) => (v>=0)) + && (((x>=0) && (y>=1)) => (v<=x))) } + GHC.Real.quotRem :: x:a -> y:a -> ({v:a | ((v = (x / y)) + && (((x>=0) && (y>=0)) => (v>=0)) + && (((x>=0) && (y>=1)) => (v<=x)))} + ,{v:a | ((v >= 0) && (v < y))}) + GHC.Real.divMod :: a -> a -> (a, a) + GHC.Real.toInteger :: x:a -> {v:GHC.Integer.Type.Integer | v = x} + +-- fixpoint can't handle (x mod y), only (x mod c) so we need to be more clever here +-- mod :: x:a -> y:a -> {v:a | v = (x mod y) } diff --git a/include/GHC/Types.spec b/include/GHC/Types.spec --- a/include/GHC/Types.spec +++ b/include/GHC/Types.spec @@ -14,8 +14,8 @@ GHC.Types.True :: {v:GHC.Types.Bool | (Prop(v))} GHC.Types.False :: {v:GHC.Types.Bool | (~ (Prop(v)))} -embed GHC.Types.Double as int +GHC.Types.isTrue# :: n:_ -> {v:GHC.Types.Bool | ((n = 1) <=> (Prop(v)))} diff --git a/include/Language/Haskell/Liquid/Foreign.hs b/include/Language/Haskell/Liquid/Foreign.hs new file mode 100644 --- /dev/null +++ b/include/Language/Haskell/Liquid/Foreign.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE MagicHash #-} + +{- OPTIONS_GHC -cpp #-} +{- OPTIONS_GHC -cpp -fglasgow-exts -} + +module Language.Haskell.Liquid.Foreign where + +import Foreign.C.Types (CSize(..)) +import Foreign.Ptr +import Foreign.ForeignPtr +import GHC.Base + +-- TODO: shouldn't have to re-import these (tests/pos/imp0.hs) +{- import Foreign.C.Types -} +{- import Foreign.Ptr -} +{- import Foreign.ForeignPtr -} +{- import GHC.Base -} + + + +----------------------------------------------------------------------------------------------- + +{-# NOINLINE intCSize #-} +{-@ assume intCSize :: x:Int -> {v: CSize | v = x } @-} +intCSize :: Int -> CSize +intCSize = fromIntegral + +{-# NOINLINE cSizeInt #-} +{-@ assume cSizeInt :: x:CSize -> {v: Int | v = x } @-} +cSizeInt :: CSize -> Int +cSizeInt = fromIntegral + + +{-@ assume mkPtr :: x:GHC.Prim.Addr# -> {v: (Ptr b) | ((plen v) = (addrLen x) && ((plen v) >= 0)) } @-} +mkPtr :: Addr# -> Ptr b +mkPtr x = undefined -- Ptr x + + +{-@ isNullPtr :: p:(Ptr a) -> {v:Bool | ((Prop v) <=> (isNullPtr p)) } @-} +isNullPtr :: Ptr a -> Bool +isNullPtr p = (p == nullPtr) +{-# INLINE isNullPtr #-} + +{-@ fpLen :: p:(ForeignPtr a) -> {v:Int | v = (fplen p) } @-} +fpLen :: ForeignPtr a -> Int +fpLen p = undefined + +{-@ pLen :: p:(Ptr a) -> {v:Int | v = (plen p) } @-} +pLen :: Ptr a -> Int +pLen p = undefined + +{-@ deref :: p:Ptr a -> {v:a | v = (deref p)} @-} +deref :: Ptr a -> a +deref = undefined + +{-@ eqPtr :: p:PtrV a + -> q:{v:PtrV a | (((pbase v) = (pbase p)) && ((plen v) <= (plen p)))} + -> {v:Bool | ((Prop v) <=> ((plen p) = (plen q)))} + @-} +eqPtr :: Ptr a -> Ptr a -> Bool +eqPtr = undefined diff --git a/include/Language/Haskell/Liquid/Prelude.hs b/include/Language/Haskell/Liquid/Prelude.hs --- a/include/Language/Haskell/Liquid/Prelude.hs +++ b/include/Language/Haskell/Liquid/Prelude.hs @@ -5,9 +5,6 @@ module Language.Haskell.Liquid.Prelude where -import Foreign.C.Types (CSize(..)) -import Foreign.Ptr -import Foreign.ForeignPtr import GHC.Base ------------------------------------------------------------------- @@ -83,8 +80,13 @@ liquidAssume :: Bool -> a -> a liquidAssume b x = x +{-@ assume liquidAssumeB :: forall

Prop>. (a

-> {v:Bool| ((Prop v) <=> true)}) -> a -> a

@-} +liquidAssumeB :: (a -> Bool) -> a -> a +liquidAssumeB p x | p x = x + | otherwise = error "liquidAssumeB fails" + {-@ assume liquidError :: {v: String | 0 = 1} -> a @-} {-# NOINLINE liquidError #-} liquidError :: String -> a @@ -118,46 +120,6 @@ isOdd x = x `mod` 2 == 1 ----------------------------------------------------------------------------------------------- - -{-# NOINLINE intCSize #-} -{-@ assume intCSize :: x:Int -> {v: CSize | v = x } @-} -intCSize :: Int -> CSize -intCSize = fromIntegral - -{-# NOINLINE cSizeInt #-} -{-@ assume cSizeInt :: x:CSize -> {v: Int | v = x } @-} -cSizeInt :: CSize -> Int -cSizeInt = fromIntegral - - -{-@ assume mkPtr :: x:GHC.Prim.Addr# -> {v: (Ptr b) | ((plen v) = (addrLen x) && ((plen v) >= 0)) } @-} -mkPtr :: Addr# -> Ptr b -mkPtr x = undefined -- Ptr x - - -{-@ isNullPtr :: p:(Ptr a) -> {v:Bool | ((Prop v) <=> (isNullPtr p)) } @-} -isNullPtr :: Ptr a -> Bool -isNullPtr p = (p == nullPtr) -{-# INLINE isNullPtr #-} - -{-@ fpLen :: p:(ForeignPtr a) -> {v:Int | v = (fplen p) } @-} -fpLen :: ForeignPtr a -> Int -fpLen p = undefined - -{-@ pLen :: p:(Ptr a) -> {v:Int | v = (plen p) } @-} -pLen :: Ptr a -> Int -pLen p = undefined - -{-@ deref :: p:Ptr a -> {v:a | v = (deref p)} @-} -deref :: Ptr a -> a -deref = undefined - -{-@ eqPtr :: p:PtrV a - -> q:{v:PtrV a | (((pbase v) = (pbase p)) && ((plen v) <= (plen p)))} - -> {v:Bool | ((Prop v) <=> ((plen p) = (plen q)))} - @-} -eqPtr :: Ptr a -> Ptr a -> Bool -eqPtr = undefined {-@ assert safeZipWith :: (a -> b -> c) -> xs : [a] -> ys:{v:[b] | len(v) = len(xs)} -> {v : [c] | len(v) = len(xs)} @-} safeZipWith :: (a->b->c) -> [a]->[b]->[c] diff --git a/include/NotReal.spec b/include/NotReal.spec new file mode 100644 --- /dev/null +++ b/include/NotReal.spec @@ -0,0 +1,11 @@ +module spec Prelude where + +import GHC.Num +assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a + -> {v:a | ((((((x = 0) || (y = 0)) => (v = 0))) + && (((x > 0) && (y > 0)) => ((v >= x) && (v >= y)))) + && (((x > 1) && (y > 1)) => ((v > x) && (v > y)))) + } + + +GHC.Real./ :: (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0.0} -> a diff --git a/include/Prelude.hquals b/include/Prelude.hquals --- a/include/Prelude.hquals +++ b/include/Prelude.hquals @@ -7,6 +7,7 @@ qualif Bot(v:int) : 0 = 1 qualif CmpZ(v:a) : v [ < ; <= ; > ; >= ; = ; != ] 0 qualif Cmp(v:a,~A:a) : v [ < ; <= ; > ; >= ; = ; != ] ~A +qualif Cmp(v:int,~A:int) : v [ < ; <= ; > ; >= ; = ; != ] ~A qualif One(v:int) : v = 1 qualif True(v:bool) : (? v) qualif False(v:bool) : ~ (? v) @@ -15,9 +16,12 @@ qualif Papp(v:a,~P:Pred a) : papp1(~P, v) -constant papp1 : func(2, [Pred @(0); @(1); bool]) +constant papp1 : func(1, [Pred @(0); @(0); bool]) qualif Papp2(v:a,~X:b,~P:Pred a b) : papp2(~P, v, ~X) constant papp2 : func(4, [Pred @(0) @(1); @(2); @(3); bool]) + +qualif Papp3(v:a,~X:b, ~Y:c, ~P:Pred a b c) : papp3(~P, v, ~X, ~Y) +constant papp3 : func(6, [Pred @(0) @(1) @(2); @(3); @(4); @(5); bool]) constant Prop : func(0, [GHC.Types.Bool; bool]) diff --git a/include/Prelude.spec b/include/Prelude.spec --- a/include/Prelude.spec +++ b/include/Prelude.spec @@ -8,7 +8,11 @@ import GHC.Word import Data.Maybe +import GHC.Exts + +GHC.Exts.D# :: x:_ -> {v:_ | v = x} + assume GHC.Base.. :: forall< p :: xx:b -> c -> Prop , q :: yy:a -> b -> Prop>. f:(x:b -> c

) -> @@ -20,16 +24,18 @@ v = (x :: int) } 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 } -assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | ((((x >= 0) && (y >= 0)) => ((v >= x) && (v >= y))) && (((x > 1) && (y > 1)) => ((v > x) && (v > y)))) } +embed GHC.Types.Double as real embed GHC.Integer.Type.Integer as int type GeInt N = {v: GHC.Types.Int | v >= N } type LeInt N = {v: GHC.Types.Int | v <= N } type Nat = {v: GHC.Types.Int | v >= 0 } +type Even = {v: GHC.Types.Int | (v mod 2) = 0 } +type Odd = {v: GHC.Types.Int | (v mod 2) = 1 } type BNat N = {v: Nat | v <= N } -predicate Max V X Y = ((X > Y) ? (V = X) : (V = Y)) -predicate Min V X Y = ((X < Y) ? (V = X) : (V = Y)) +predicate Max V X Y = if X > Y then V = X else V = Y +predicate Min V X Y = if X < Y then V = X else V = Y type IncrListD a D = [a]<{\x y -> (x+D) <= y}> diff --git a/include/Real.spec b/include/Real.spec new file mode 100644 --- /dev/null +++ b/include/Real.spec @@ -0,0 +1,9 @@ +module spec Prelude where + +import GHC.Num + +assume GHC.Num.* :: (GHC.Num.Num a) => x:a -> y:a -> {v:a | v = x * y} + + + +GHC.Real./ :: (GHC.Real.Fractional a) => x:a -> y:{v:a | v != 0.0} -> {v: a | v = (x / y) } diff --git a/liquidhaskell.cabal b/liquidhaskell.cabal --- a/liquidhaskell.cabal +++ b/liquidhaskell.cabal @@ -1,5 +1,5 @@ Name: liquidhaskell -Version: 0.1 +Version: 0.2.0.0 Copyright: 2010-13 Ranjit Jhala, University of California, San Diego. build-type: Simple Synopsis: Liquid Types for Haskell @@ -7,11 +7,11 @@ Homepage: http://goto.ucsd.edu/liquidhaskell License: GPL License-file: LICENSE -Author: Ranjit Jhala +Author: Ranjit Jhala, Niki Vazou, Eric Seidel Maintainer: Ranjit Jhala Category: Language Build-Type: Simple -Cabal-version: >=1.8 +Cabal-version: >=1.18 data-files: include/*.hquals , include/*.hs @@ -25,24 +25,32 @@ , include/Foreign/*.spec , include/Foreign/C/*.spec , include/Foreign/Marshal/*.spec - , include/GHC/List.lhs , include/GHC/*.hquals , include/GHC/*.spec , include/GHC/IO/*.spec - , include/Language/Haskell/Liquid/List.hs - , include/Language/Haskell/Liquid/Prelude.hs - , include/Language/Haskell/Liquid/Prelude.pred + , include/Language/Haskell/Liquid/*.hs + , include/Language/Haskell/Liquid/*.pred , include/System/*.spec , syntax/liquid.css -Executable liquid +Source-Repository head + Type: git + Location: https://github.com/ucsd-progsys/liquidhaskell/ + +Executable liquid + default-language: Haskell98 Build-Depends: base >= 4 && < 5 - , ghc==7.6.3 + , ghc>=7.8.3 , ansi-terminal + , template-haskell + , time + , array + , hpc , bifunctors , cmdargs , containers , cpphs + , data-default , deepseq , directory , Diff @@ -57,25 +65,67 @@ , syb , text , vector - , liquid-fixpoint - , hashable<1.2 + , liquid-fixpoint >= 0.2 + , hashable , unordered-containers , aeson , bytestring - -- , liquidtypes + , fingertree + , liquidhaskell Main-is: Liquid.hs --ghc-options: -O -W - Extensions: PatternGuards + Default-Extensions: PatternGuards +-- Executable liquid-count-binders +-- Build-Depends: base >= 4 && < 5 +-- , ghc==7.6.3 +-- , ansi-terminal +-- , bifunctors +-- , cmdargs +-- , containers +-- , cpphs +-- , deepseq +-- , directory +-- , Diff +-- , filemanip +-- , filepath +-- , ghc-paths +-- , hscolour +-- , mtl +-- , parsec +-- , pretty +-- , process +-- , syb +-- , text +-- , vector +-- , liquid-fixpoint +-- , hashable +-- , unordered-containers +-- , aeson +-- , bytestring +-- , fingertree +-- , liquidhaskell +-- +-- Main-is: CountBinders.hs +-- --ghc-options: -O -W +-- Extensions: PatternGuards + + Library + Default-Language: Haskell98 Build-Depends: base - , ghc==7.6.3 + , ghc>=7.8.3 , ansi-terminal + , template-haskell + , time + , array + , hpc , bifunctors , cmdargs , containers , cpphs + , data-default , deepseq , directory , Diff @@ -89,16 +139,20 @@ , process , syb , text + , unix + , intern , vector - , hashable<1.2 + , hashable , unordered-containers - , liquid-fixpoint + , liquid-fixpoint >= 0.2 , aeson , bytestring + , fingertree - hs-source-dirs: include, . + hs-source-dirs: include, src Exposed-Modules: Language.Haskell.Liquid.Prelude, + Language.Haskell.Liquid.Foreign, Language.Haskell.Liquid.List, Language.Haskell.Liquid.PrettyPrint, Language.Haskell.Liquid.Bare, @@ -106,25 +160,33 @@ Language.Haskell.Liquid.Measure, Language.Haskell.Liquid.Parse, Language.Haskell.Liquid.GhcInterface, + Language.Haskell.Liquid.World, Language.Haskell.Liquid.RefType, + Language.Haskell.Liquid.Errors, Language.Haskell.Liquid.PredType, - Language.Haskell.Liquid.Predicates, Language.Haskell.Liquid.ACSS, Language.Haskell.Liquid.DiffCheck, Language.Haskell.Liquid.ANFTransform, Language.Haskell.Liquid.Annotate, - Language.Haskell.Liquid.CTags, + Language.Haskell.Liquid.CTags, Language.Haskell.Liquid.CmdLine, Language.Haskell.Liquid.GhcMisc, Language.Haskell.Liquid.Misc, Language.Haskell.Liquid.Qualifier, Language.Haskell.Liquid.TransformRec, Language.Haskell.Liquid.Tidy, - Language.Haskell.Liquid.Types - Language.Haskell.Liquid.Fresh - - other-modules: Language.Haskell.Liquid.Desugar.Desugar + Language.Haskell.Liquid.Types, + Language.Haskell.Liquid.Strata, + Language.Haskell.Liquid.Fresh, + Paths_liquidhaskell, + + --NOTE: these need to be exposed so GHC generates .dyn_o files for them.. + Language.Haskell.Liquid.Desugar.Desugar, 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.DsListComp, Language.Haskell.Liquid.Desugar.MatchCon, Language.Haskell.Liquid.Desugar.MatchLit, @@ -135,6 +197,23 @@ Language.Haskell.Liquid.Desugar.DsGRHSs, Language.Haskell.Liquid.Desugar.HscMain --ghc-options: -O -W - Extensions: PatternGuards - + ghc-prof-options: -fprof-auto + Default-Extensions: PatternGuards +test-suite test + default-language: Haskell98 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + ghc-options: -O2 -threaded + main-is: test.hs + build-depends: base, + directory, + filepath, + process, + tagged, + unix, + liquidhaskell, + optparse-applicative < 0.10, + tasty >= 0.8, + tasty-hunit >= 0.8, + tasty-rerun >= 1.1 diff --git a/src/Language/Haskell/Liquid/ACSS.hs b/src/Language/Haskell/Liquid/ACSS.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/ACSS.hs @@ -0,0 +1,296 @@ +-- | Formats Haskell source code as HTML with CSS and Mouseover Type Annotations +module Language.Haskell.Liquid.ACSS ( + hscolour + , hsannot + , AnnMap (..) + , breakS + , srcModuleName + , Status (..) + ) where + +import Language.Haskell.HsColour.Anchors +import Language.Haskell.HsColour.Classify as Classify +import Language.Haskell.HsColour.HTML (renderAnchors, escape) +import qualified Language.Haskell.HsColour.CSS as CSS + +import Data.Either (partitionEithers) +import Data.Maybe (fromMaybe) +import qualified Data.HashMap.Strict as M +import Data.List (find, isPrefixOf, findIndex, elemIndices, intercalate) +import Data.Char (isSpace) +import Text.Printf +import Language.Haskell.Liquid.GhcMisc +-- import Language.Fixpoint.Misc +-- import Data.Monoid + + +-- import Debug.Trace + +data AnnMap = Ann { + types :: M.HashMap Loc (String, String) -- ^ Loc -> (Var, Type) + , errors :: [(Loc, Loc, String)] -- ^ List of error intervals + , status :: !Status + } + +data Status = Safe | Unsafe | Error | Crash + deriving (Eq, Ord, Show) + +emptyAnnMap = Ann M.empty [] + +data Annotation = A { + typ :: Maybe String -- ^ type string + , err :: Maybe String -- ^ error string + , lin :: Maybe (Int, Int) -- ^ line number, total width of lines i.e. max (length (show lineNum)) + } deriving (Show) + +getFirstMaybe x@(Just _) _ = x +getFirstMaybe Nothing y = y + + +-- | Formats Haskell source code using HTML and mouse-over annotations +hscolour :: Bool -- ^ Whether to include anchors. + -> Bool -- ^ Whether input document is literate haskell or not + -> String -- ^ Haskell source code, Annotations as comments at end + -> String -- ^ Coloured Haskell source code. + +hscolour anchor lhs = hsannot anchor Nothing lhs . splitSrcAndAnns + +type CommentTransform = Maybe (String -> [(TokenType, String)]) + +-- | Formats Haskell source code using HTML and mouse-over annotations +hsannot :: Bool -- ^ Whether to include anchors. + -> CommentTransform -- ^ Function to refine comment tokens + -> Bool -- ^ Whether input document is literate haskell or not + -> (String, AnnMap) -- ^ Haskell Source, Annotations + -> String -- ^ Coloured Haskell source code. + +hsannot anchor tx False z = hsannot' Nothing anchor tx z +hsannot anchor tx True (s, m) = concatMap chunk $ litSpans $ joinL $ classify $ inlines s + where chunk (Code c, l) = hsannot' (Just l) anchor tx (c, m) + chunk (Lit c , _) = c + +litSpans :: [Lit] -> [(Lit, Loc)] +litSpans lits = zip lits $ spans lits + where spans = tokenSpans Nothing . map unL + +hsannot' baseLoc anchor tx = + CSS.pre + . (if anchor then concatMap (renderAnchors renderAnnotToken) + . insertAnnotAnchors + else concatMap renderAnnotToken) + . annotTokenise baseLoc tx + +-- | annotTokenise is absurdly slow: O(#tokens x #errors) + +annotTokenise :: Maybe Loc -> CommentTransform -> (String, AnnMap) -> [(TokenType, String, Annotation)] +annotTokenise baseLoc tx (src, annm) = zipWith (\(x,y) z -> (x,y,z)) toks annots + where + toks = tokeniseWithCommentTransform tx src + spans = tokenSpans baseLoc $ map snd toks + annots = fmap (spanAnnot linWidth annm) spans + linWidth = length $ show $ length $ lines src + +spanAnnot w (Ann ts es _) span = A t e b + where + t = fmap snd (M.lookup span ts) + e = fmap (\_ -> "ERROR") $ find (span `inRange`) [(x,y) | (x,y,_) <- es] + b = spanLine w span + +spanLine w (L (l, c)) + | c == 1 = Just (l, w) + | otherwise = Nothing + +inRange (L (l0, c0)) (L (l, c), L (l', c')) + = l <= l0 && c <= c0 && l0 <= l' && c0 < c' + +tokeniseWithCommentTransform :: Maybe (String -> [(TokenType, String)]) -> String -> [(TokenType, String)] +tokeniseWithCommentTransform Nothing = tokenise +tokeniseWithCommentTransform (Just f) = concatMap (expand f) . tokenise + where expand f (Comment, s) = f s + expand _ z = [z] + +tokenSpans :: Maybe Loc -> [String] -> [Loc] +tokenSpans = scanl plusLoc . fromMaybe (L (1, 1)) + +plusLoc :: Loc -> String -> Loc +plusLoc (L (l, c)) s + = case '\n' `elemIndices` s of + [] -> L (l, (c + n)) + is -> L ((l + length is), (n - maximum is)) + where n = length s + +renderAnnotToken :: (TokenType, String, Annotation) -> String +renderAnnotToken (x, y, a) = renderLinAnnot (lin a) + $ renderErrAnnot (err a) + $ renderTypAnnot (typ a) + $ CSS.renderToken (x, y) + + + +renderTypAnnot (Just ann) s = printf "%s%s" (escape ann) s +renderTypAnnot Nothing s = s + +renderErrAnnot (Just _) s = printf "%s" s +renderErrAnnot Nothing s = s + +renderLinAnnot (Just d) s = printf "%s: %s" (lineString d) s +renderLinAnnot Nothing s = s + +lineString (i, w) = (replicate (w - (length is)) ' ') ++ is + where is = show i + +{- Example Annotation: +x#agV:Int -> {VV_int:Int | (0 <= VV_int),(x#agV <= VV_int)} +NOWTRYTHIS +-} + + +insertAnnotAnchors :: [(TokenType, String, a)] -> [Either String (TokenType, String, a)] +insertAnnotAnchors toks + = stitch (zip toks' toks) $ insertAnchors toks' + where toks' = [(x,y) | (x,y,_) <- toks] + +stitch :: Eq b => [(b, c)] -> [Either a b] -> [Either a c] +stitch xys ((Left a) : rest) + = (Left a) : stitch xys rest +stitch ((x,y):xys) ((Right x'):rest) + | x == x' + = (Right y) : stitch xys rest + | otherwise + = error "stitch" +stitch _ [] + = [] + + +splitSrcAndAnns :: String -> (String, AnnMap) +splitSrcAndAnns s = + let ls = lines s in + case findIndex (breakS ==) ls of + Nothing -> (s, Ann M.empty [] Safe) + Just i -> (src, ann) + where (codes, _:mname:annots) = splitAt i ls + ann = annotParse mname $ dropWhile isSpace $ unlines annots + src = unlines codes + +srcModuleName :: String -> String +srcModuleName = fromMaybe "Main" . tokenModule . tokenise + +tokenModule toks + = do i <- findIndex ((Keyword, "module") ==) toks + let (_, toks') = splitAt (i+2) toks + j <- findIndex ((Space ==) . fst) toks' + let (toks'', _) = splitAt j toks' + return $ concatMap snd toks'' + +breakS = "MOUSEOVER ANNOTATIONS" + +-- annotParse :: String -> String -> AnnMap +-- annotParse mname = Ann . M.map reduce . group . parseLines mname 0 . lines +-- where +-- group = foldl' (\m (k, v) -> inserts k v m) M.empty +-- reduce anns@((x,_):_) = (x, mconcat $ map snd anns) +-- inserts k v m = M.insert k (v : M.lookupDefault [] k m) m + +annotParse :: String -> String -> AnnMap +annotParse mname s = Ann (M.fromList ts) [(x,y,"") | (x,y) <- es] Safe + where + (ts, es) = partitionEithers $ parseLines mname 0 $ lines s + + +parseLines _ _ [] + = [] + +parseLines mname i ("":ls) + = parseLines mname (i+1) ls + +parseLines mname i (_:_:l:c:"0":l':c':rest') + = Right (L (line, col), L (line', col')) : parseLines mname (i + 7) rest' + where line = (read l) :: Int + col = (read c) :: Int + line' = (read l') :: Int + col' = (read c') :: Int + +parseLines mname i (x:f:l:c:n:rest) + | f /= mname + = parseLines mname (i + 5 + num) rest' + | otherwise + = Left (L (line, col), (x, anns)) : parseLines mname (i + 5 + num) rest' + where line = (read l) :: Int + col = (read c) :: Int + num = (read n) :: Int + anns = intercalate "\n" $ take num rest + rest' = drop num rest + +parseLines _ i _ + = error $ "Error Parsing Annot Input on Line: " ++ show i + +-- stringAnnotation s +-- | "ERROR" `isPrefixOf` s = A Nothing (Just s) +-- | otherwise = A (Just s) Nothing + +-- takeFileName s = map slashWhite s +-- where slashWhite '/' = ' ' + +instance Show AnnMap where + show (Ann ts es _ ) = "\n\n" ++ (concatMap ppAnnotTyp $ M.toList ts) + ++ (concatMap ppAnnotErr [(x,y) | (x,y,_) <- es]) + +ppAnnotTyp (L (l, c), (x, s)) = printf "%s\n%d\n%d\n%d\n%s\n\n\n" x l c (length $ lines s) s +ppAnnotErr (L (l, c), L (l', c')) = printf " \n%d\n%d\n0\n%d\n%d\n\n\n\n" l c l' c' + +-- where ppAnnot (L (l, c), (x,s)) = x ++ "\n" +-- ++ show l ++ "\n" +-- ++ show c ++ "\n" +-- ++ show (length $ lines s) ++ "\n" +-- ++ s ++ "\n\n\n" + + +--------------------------------------------------------------------------------- +---- Code for Dealing With LHS, stolen from Language.Haskell.HsColour.HsColour -- +--------------------------------------------------------------------------------- + +-- | Separating literate files into code\/comment chunks. +data Lit = Code {unL :: String} | Lit {unL :: String} deriving (Show) + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +-- And retains the trailing '\n' character in each resultant string. +inlines :: String -> [String] +inlines s = lines' s id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc ['\n'] : lines' s id -- DOS +--lines' ('\^M':s) acc = acc ['\n'] : lines' s id -- MacOS + lines' ('\n':s) acc = acc ['\n'] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + + +-- | The code for classify is largely stolen from Language.Preprocessor.Unlit. +classify :: [String] -> [Lit] +classify [] = [] +classify (x:xs) | "\\begin{code}"`isPrefixOf`x + = Lit x: allProg "code" xs +classify (x:xs) | "\\begin{spec}"`isPrefixOf`x + = Lit x: allProg "spec" xs +classify (('>':x):xs) = Code ('>':x) : classify xs +classify (x:xs) = Lit x: classify xs + + +allProg name = go + where + end = "\\end{" ++ name ++ "}" + go [] = [] -- Should give an error message, + -- but I have no good position information. + go (x:xs) | end `isPrefixOf `x + = Lit x: classify xs + go (x:xs) = Code x: go xs + + + +-- | Join up chunks of code\/comment that are next to each other. +joinL :: [Lit] -> [Lit] +joinL [] = [] +joinL (Code c:Code c2:xs) = joinL (Code (c++c2):xs) +joinL (Lit c :Lit c2 :xs) = joinL (Lit (c++c2):xs) +joinL (any:xs) = any: joinL xs + diff --git a/src/Language/Haskell/Liquid/ANFTransform.hs b/src/Language/Haskell/Liquid/ANFTransform.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/ANFTransform.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------------- +------------ Code to convert Core to Administrative Normal Form --------------------- +------------------------------------------------------------------------------------- + +module Language.Haskell.Liquid.ANFTransform (anormalize) where +import Coercion (isCoVar, isCoVarType) +import CoreSyn +import CoreUtils (exprType) +import qualified DsMonad +import DsMonad (initDs) +import FastString (fsLit) +import GHC hiding (exprType) +import HscTypes +import Id (mkSysLocalM) +import Literal +import MkCore (mkCoreLets) +import Outputable (trace) +import Var (varType, setVarType) +import TypeRep +import Type (mkForAllTys, substTy, mkForAllTys, mkTopTvSubst) +import TyCon (tyConDataCons_maybe) +import DataCon (dataConInstArgTys) +import FamInstEnv (emptyFamInstEnv) +import VarEnv (VarEnv, emptyVarEnv, extendVarEnv, lookupWithDefaultVarEnv) +import Control.Monad.State.Lazy +import Control.Monad.Trans (lift) +import Control.Monad +import Control.Applicative ((<$>)) +import UniqSupply (MonadUnique) +import Language.Fixpoint.Types (anfPrefix) +import Language.Haskell.Liquid.GhcMisc (MGIModGuts(..), showPpr, symbolFastString) +import Language.Haskell.Liquid.TransformRec +import Language.Fixpoint.Misc (fst3, errorstar) +import Data.Maybe (fromMaybe) +import Data.List (sortBy, (\\)) +import Control.Applicative +import qualified Data.Text as T + +anormalize :: Bool -> HscEnv -> MGIModGuts -> IO [CoreBind] +anormalize expandFlag hscEnv modGuts + = do -- putStrLn "***************************** GHC CoreBinds ***************************" + -- putStrLn $ showPpr orig_cbs + liftM (fromMaybe err . snd) $ initDs hscEnv m grEnv tEnv emptyFamInstEnv act + where m = mgi_module modGuts + grEnv = mgi_rdr_env modGuts + tEnv = modGutsTypeEnv modGuts + act = liftM concat $ mapM (normalizeTopBind expandFlag emptyVarEnv) orig_cbs + orig_cbs = transformRecExpr $ mgi_binds modGuts + err = errorstar "anormalize fails!" + +modGutsTypeEnv mg = typeEnvFromEntities ids tcs fis + where ids = bindersOfBinds (mgi_binds mg) + tcs = mgi_tcs mg + fis = mgi_fam_insts mg + +------------------------------------------------------------------ +----------------- Actual Normalizing Functions ------------------- +------------------------------------------------------------------ + +-- Can't make the below default for normalizeBind as it +-- fails tests/pos/lets.hs due to GHCs odd let-bindings + +normalizeTopBind :: Bool -> VarEnv Id -> Bind CoreBndr -> DsMonad.DsM [CoreBind] +normalizeTopBind expandFlag γ (NonRec x e) + = do e' <- runDsM $ evalStateT (stitch γ e) (DsST expandFlag []) + return [normalizeTyVars $ NonRec x e'] + +normalizeTopBind expandFlag γ (Rec xes) + = do xes' <- runDsM $ execStateT (normalizeBind γ (Rec xes)) (DsST expandFlag []) + return $ map normalizeTyVars (st_binds xes') + +normalizeTyVars (NonRec x e) = NonRec (setVarType x t') e + where t' = subst msg as as' bt + msg = "WARNING unable to renameVars on " ++ showPpr x + as' = fst $ collectTyBinders e + (as, bt) = splitForAllTys (varType x) +normalizeTyVars (Rec xes) = Rec xes' + where nrec = normalizeTyVars <$> ((\(x, e) -> NonRec x e) <$> xes) + xes' = (\(NonRec x e) -> (x, e)) <$> nrec + +subst msg as as' bt + | length as == length as' + = mkForAllTys as' $ substTy su bt + | otherwise + = trace msg $ mkForAllTys as bt + where su = mkTopTvSubst $ zip as (mkTyVarTys as') + + +newtype DsM a = DsM {runDsM :: DsMonad.DsM a} + deriving (Functor, Monad, MonadUnique, Applicative) + +data DsST = DsST { st_expandflag :: Bool + , st_binds :: [CoreBind] + } + +type DsMW = StateT DsST DsM + +------------------------------------------------------------------ +normalizeBind :: VarEnv Id -> CoreBind -> DsMW () +------------------------------------------------------------------ + +normalizeBind γ (NonRec x e) + = do e' <- normalize γ e + add [NonRec x e'] + +normalizeBind γ (Rec xes) + = do es' <- mapM (stitch γ) es + add [Rec (zip xs es')] + where (xs, es) = unzip xes + +-------------------------------------------------------------------- +normalizeName :: VarEnv Id -> CoreExpr -> DsMW CoreExpr +-------------------------------------------------------------------- + +-- normalizeNameDebug γ e +-- = liftM (tracePpr ("normalizeName" ++ showPpr e)) $ normalizeName γ e + +normalizeName _ e@(Lit (LitInteger _ _)) + = normalizeLiteral e + +normalizeName _ e@(Tick _ (Lit (LitInteger _ _))) + = normalizeLiteral e + +normalizeName γ (Var x) + = return $ Var (lookupWithDefaultVarEnv γ x x) + +normalizeName _ e@(Type _) + = return e + +normalizeName _ e@(Lit _) + = return e + +normalizeName γ e@(Coercion _) + = do x <- lift $ freshNormalVar $ exprType e + add [NonRec x e] + return $ Var x + +normalizeName γ (Tick n e) + = do e' <- normalizeName γ e + return $ Tick n e' + +normalizeName γ e + = do e' <- normalize γ e + x <- lift $ freshNormalVar $ exprType e + add [NonRec x e'] + return $ Var x + + +add :: [CoreBind] -> DsMW () +add w = modify $ \s -> s{st_binds = st_binds s++w} + +--------------------------------------------------------------------- +normalizeLiteral :: CoreExpr -> DsMW CoreExpr +--------------------------------------------------------------------- + +normalizeLiteral e = + do x <- lift $ freshNormalVar (exprType e) + add [NonRec x e] + return $ Var x + +freshNormalVar :: Type -> DsM Id +freshNormalVar = mkSysLocalM (symbolFastString anfPrefix) + +--------------------------------------------------------------------- +normalize :: VarEnv Id -> CoreExpr -> DsMW CoreExpr +--------------------------------------------------------------------- + +normalize γ (Lam x e) + = do e' <- stitch γ e + return $ Lam x e' + +normalize γ (Let b e) + = do normalizeBind γ b + normalize γ e + -- Need to float bindings all the way up to the top + -- Due to GHCs odd let-bindings (see tests/pos/lets.hs) + +normalize γ (Case e x t as) + = do n <- normalizeName γ e + x' <- lift $ freshNormalVar τx -- rename "wild" to avoid shadowing + let γ' = extendVarEnv γ x x' + as' <- forM as $ \(c, xs, e') -> liftM (c, xs,) (stitch γ' e') + flag <- st_expandflag <$> get + as'' <- lift $ expandDefaultCase flag τx as' + return $ Case n x' t as'' + where τx = varType x + +normalize γ (Var x) + = return $ Var (lookupWithDefaultVarEnv γ x x) + +normalize _ e@(Lit _) + = return e + +normalize _ e@(Type _) + = return e + +normalize γ (Cast e τ) + = do e' <- normalizeName γ e + return $ Cast e' τ + +normalize γ (App e1 e2) + = do e1' <- normalize γ e1 + n2 <- normalizeName γ e2 + return $ App e1' n2 + +normalize γ (Tick n e) + = do e' <- normalize γ e + return $ Tick n e' + +normalize _ (Coercion c) + = return $ Coercion c + +stitch :: VarEnv Id -> CoreExpr -> DsMW CoreExpr +stitch γ e + = do bs' <- get + modify $ \s -> s {st_binds = []} + e' <- normalize γ e + bs <- st_binds <$> get + put bs' + return $ mkCoreLets bs e' + +---------------------------------------------------------------------------------- +expandDefaultCase :: Bool -> Type -> [(AltCon, [Id], CoreExpr)] -> DsM [(AltCon, [Id], CoreExpr)] +---------------------------------------------------------------------------------- + +expandDefaultCase flag tyapp zs@((DEFAULT, _ ,_) : _) | flag + = expandDefaultCase' tyapp zs + +expandDefaultCase _ tyapp@(TyConApp tc _) z@((DEFAULT, _ ,_):dcs) + = case tyConDataCons_maybe tc of + Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs] + if (length ds') == 1 + then expandDefaultCase' tyapp z + else return z + Nothing -> return z -- + +expandDefaultCase _ _ z + = return z + +expandDefaultCase' (TyConApp tc argτs) z@((DEFAULT, _ ,e) : dcs) + = case tyConDataCons_maybe tc of + Just ds -> do let ds' = ds \\ [ d | (DataAlt d, _ , _) <- dcs] + dcs' <- forM ds' $ cloneCase argτs e + return $ sortCases $ dcs' ++ dcs + Nothing -> return z -- +expandDefaultCase' _ z + = return z + +cloneCase argτs e d + = do xs <- mapM freshNormalVar $ dataConInstArgTys d argτs + return (DataAlt d, xs, e) + +sortCases = sortBy (\x y -> cmpAltCon (fst3 x) (fst3 y)) + diff --git a/src/Language/Haskell/Liquid/Annotate.hs b/src/Language/Haskell/Liquid/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Annotate.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +--------------------------------------------------------------------------- +-- | 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. +--------------------------------------------------------------------------- + +module Language.Haskell.Liquid.Annotate (mkOutput, annotate) where + +import GHC ( SrcSpan (..) + , srcSpanStartCol + , srcSpanEndCol + , srcSpanStartLine + , srcSpanEndLine + , RealSrcSpan (..)) +import Var (Var (..)) +import TypeRep (Prec(..)) +import Text.PrettyPrint.HughesPJ hiding (first, second) +import GHC.Exts (groupWith, sortWith) + +import Data.Char (isSpace) +import Data.Function (on) +import Data.List (sortBy) +import Data.Maybe (mapMaybe) + +import Data.Aeson +import Control.Arrow hiding ((<+>)) +import Control.Applicative ((<$>)) +import Control.DeepSeq +import Control.Monad (when, forM_) +import Data.Monoid + +import System.FilePath (takeFileName, dropFileName, ()) +import System.Directory (findExecutable, copyFile) +import Text.Printf (printf) +import qualified Data.List as L +import qualified Data.Vector as V +import qualified Data.ByteString.Lazy as B +import qualified Data.Text as T +import qualified Data.HashMap.Strict as M +import qualified Language.Haskell.Liquid.ACSS as ACSS +import Language.Haskell.HsColour.Classify +import Language.Fixpoint.Files +import Language.Fixpoint.Names hiding (encode) +import Language.Fixpoint.Misc +import Language.Haskell.Liquid.GhcMisc +import Language.Fixpoint.Types hiding (Def (..), Located (..)) +import Language.Haskell.Liquid.Misc +import Language.Haskell.Liquid.PrettyPrint +import Language.Haskell.Liquid.RefType +import Language.Haskell.Liquid.Errors +import Language.Haskell.Liquid.Tidy +import Language.Haskell.Liquid.Types hiding (Located(..), Def(..)) + +-- | @output@ creates the pretty printed output +-------------------------------------------------------------------------------------------- +mkOutput :: Config -> FixResult Error -> FixSolution -> AnnInfo (Annot SpecType) -> Output Doc +-------------------------------------------------------------------------------------------- +mkOutput cfg res sol anna + = O { o_vars = Nothing + , o_warns = [] + , o_types = toDoc <$> annTy + , o_templs = toDoc <$> annTmpl + , o_bots = mkBots annTy + , o_result = res + } + where + annTmpl = closeAnnots anna + 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 :: Config -> FilePath -> Output Doc -> IO () +------------------------------------------------------------------- +annotate cfg srcF out + = do generateHtml srcF tpHtmlF tplAnnMap + generateHtml srcF tyHtmlF typAnnMap + writeFile vimF $ vimAnnot cfg annTyp + B.writeFile jsonF $ encode typAnnMap + forM_ bots (printf "WARNING: Found false in %s\n" . showPpr) + where + tplAnnMap = mkAnnMap cfg result annTpl + typAnnMap = mkAnnMap cfg result annTyp + annTpl = o_templs out + annTyp = o_types out + result = o_result out + bots = o_bots out + tyHtmlF = extFileName Html srcF + tpHtmlF = extFileName Html $ extFileName Cst srcF + annF = extFileName Annot srcF + jsonF = extFileName Json srcF + vimF = extFileName Vim srcF + +mkBots (AI m) = [ src | (src, (Just _, t) : _) <- sortBy (compare `on` fst) $ M.toList m + , isFalse (rTypeReft t) ] + +writeFilesOrStrings :: FilePath -> [Either FilePath String] -> IO () +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) + renderHtml lhs htmlF srcF (takeFileName cssFile) body + +renderHtml True = renderPandoc +renderHtml False = renderDirect + +------------------------------------------------------------------------- +-- | Pandoc HTML Rendering (for lhs + markdown source) ------------------ +------------------------------------------------------------------------- + +renderPandoc htmlFile srcFile css body + = 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 + writeFilesOrStrings htmlFile [Right (cssHTML css)] + checkExitCode cmd ec + 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 + +pandocPreProc = T.unpack + . strip beg code + . strip end code + . strip beg spec + . strip end spec + . T.pack + where + beg, end, code, spec :: String + beg = "begin" + end = "end" + code = "code" + 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 + + + + +------------------------------------------------------------------------- +-- | Direct HTML Rendering (for non-lhs/markdown source) ---------------- +------------------------------------------------------------------------- + +-- More or less taken from hscolour + +renderDirect htmlFile srcFile css body + = writeFile htmlFile $! (top'n'tail full srcFile css $! body) + where full = True -- False -- TODO: command-line-option + +-- | @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) +top'n'tail False _ _ = id + +-- Use this for standalone HTML + +htmlHeader title css = unlines + [ "" + , "" + , "" + , "" ++ title ++ "" + , "" + , cssHTML css + , "" + , "

" + , "Put mouse over identifiers to see inferred types" + ] + +htmlClose = "\n\n" + +cssHTML css = unlines + [ "" + , "" + , "" + ] + +------------------------------------------------------------------------------ +-- | Building Annotation Maps ------------------------------------------------ +------------------------------------------------------------------------------ + +-- | This function converts our annotation information into that which +-- is required by `Language.Haskell.Liquid.ACSS` to generate mouseover +-- annotations. + +mkAnnMap :: Config -> FixResult Error -> AnnInfo Doc -> ACSS.AnnMap +mkAnnMap cfg res ann = ACSS.Ann (mkAnnMapTyp cfg ann) (mkAnnMapErr res) (mkStatus res) + +mkStatus (Safe) = ACSS.Safe +mkStatus (Unsafe _) = ACSS.Unsafe +mkStatus (Crash _ _) = ACSS.Error +mkStatus _ = ACSS.Crash + +mkAnnMapErr (Unsafe 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 _ = Nothing + + +-- mkAnnMapTyp :: (RefTypable a c tv r, RefTypable a c tv (), PPrint tv, PPrint a) =>Config-> AnnInfo (RType a c tv r) -> M.HashMap Loc (String, String) +mkAnnMapTyp cfg z = M.fromList $ map (first srcSpanStartLoc) $ mkAnnMapBinders cfg z + +mkAnnMapBinders cfg (AI m) + = map (second bindStr . head . sortWith (srcSpanEndCol . fst)) + $ groupWith (lineCol . fst) + [ (l, x) | (RealSrcSpan l, x:_) <- M.toList m, oneLine l] + where + 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 = closeA . filterA . collapseA + +closeA a@(AI m) = cf <$> a + where + cf (AnnLoc l) = case m `mlookup` l of + [(_, AnnUse t)] -> t + [(_, AnnDef t)] -> t + [(_, AnnRDf t)] -> t + _ -> errorstar $ "malformed AnnInfo: " ++ showPpr l + cf (AnnUse t) = t + cf (AnnDef t) = t + cf (AnnRDf t) = t + +filterA (AI m) = AI (M.filter ff m) + where + ff [(_, AnnLoc l)] = l `M.member` m + ff _ = True + +collapseA (AI m) = AI (fmap pickOneA m) + +pickOneA xas = case (rs, ds, ls, us) of + (x:_, _, _, _) -> [x] + (_, x:_, _, _) -> [x] + (_, _, x:_, _) -> [x] + (_, _, _, x:_) -> [x] + where + rs = [x | x@(_, AnnRDf _) <- xas] + ds = [x | x@(_, AnnDef _) <- xas] + ls = [x | x@(_, AnnLoc _) <- xas] + us = [x | x@(_, AnnUse _) <- xas] + +------------------------------------------------------------------------------ +-- | Tokenizing Refinement Type Annotations in @-blocks ---------------------- +------------------------------------------------------------------------------ + +-- | The token used for refinement symbols inside the highlighted types in @-blocks. +refToken = Keyword + +-- | The top-level function for tokenizing @-block annotations. Used to +-- tokenize comments by ACSS. +tokAnnot s + = case trimLiquidAnnot s of + Just (l, body, r) -> [(refToken, l)] ++ tokBody body ++ [(refToken, r)] + Nothing -> [(Comment, s)] + +trimLiquidAnnot ('{':'-':'@':ss) + | drop (length ss - 3) ss == "@-}" + = Just ("{-@", take (length ss - 3) ss, "@-}") +trimLiquidAnnot _ + = Nothing + +tokBody s + | isData s = tokenise s + | isType s = tokenise s + | isIncl s = tokenise s + | isMeas s = tokenise s + | otherwise = tokeniseSpec s + +isMeas = spacePrefix "measure" +isData = spacePrefix "data" +isType = spacePrefix "type" +isIncl = spacePrefix "include" + +spacePrefix str s@(c:cs) + | isSpace c = spacePrefix str cs + | otherwise = take (length str) s == str +spacePrefix _ _ = False + + +tokeniseSpec :: String -> [(TokenType, String)] +tokeniseSpec str = {- traceShow ("tokeniseSpec: " ++ str) $ -} tokeniseSpec' str + +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) $ -} + filter (/= "") $ concatMap (chopAlts [("{", ":"), ("|", "}")]) + $ chopAlts [("<{", "}>"), ("{", "}")] y + + + + +------------------------------------------------------------------------ +-- | JSON: Annotation Data Types --------------------------------------- +------------------------------------------------------------------------ + +data Assoc k a = Asc (M.HashMap k a) +type AnnTypes = Assoc Int (Assoc Int Annot1) +type AnnErrors = [(Loc, Loc, String)] +data Annot1 = A1 { ident :: String + , ann :: String + , row :: Int + , col :: Int + } + +------------------------------------------------------------------------ +-- | Creating Vim Annotations ------------------------------------------ +------------------------------------------------------------------------ + +vimAnnot :: Config -> AnnInfo Doc -> String +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) + where + l1 = srcSpanStartLine sp + c1 = srcSpanStartCol sp + l2 = srcSpanEndLine sp + c2 = srcSpanEndCol sp + +------------------------------------------------------------------------ +-- | JSON Instances ---------------------------------------------------- +------------------------------------------------------------------------ + +instance ToJSON ACSS.Status where + toJSON ACSS.Safe = "safe" + toJSON ACSS.Unsafe = "unsafe" + toJSON ACSS.Error = "error" + toJSON ACSS.Crash = "crash" + +instance ToJSON Annot1 where + toJSON (A1 i a r c) = object [ "ident" .= i + , "ann" .= a + , "row" .= r + , "col" .= c + ] + +instance ToJSON Loc where + toJSON (L (l, c)) = object [ "line" .= toJSON l + , "column" .= toJSON c ] + +instance ToJSON AnnErrors where + toJSON errs = Array $ V.fromList $ fmap toJ errs + 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 + +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 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 + 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 + Asc rm = M.lookupDefault (Asc M.empty) r m + + + +-------------------------------------------------------------------------------- +-- | A Little Unit Test -------------------------------------------------------- +-------------------------------------------------------------------------------- + +anns :: AnnTypes +anns = i [(5, i [( 14, A1 { ident = "foo" + , ann = "int -> int" + , row = 5 + , col = 14 + }) + ] + ) + ,(9, i [( 22, A1 { ident = "map" + , ann = "(a -> b) -> [a] -> [b]" + , row = 9 + , col = 22 + }) + ,( 28, A1 { ident = "xs" + , ann = "[b]" + , row = 9 + , col = 28 + }) + ]) + ] + +i = Asc . M.fromList + + + diff --git a/src/Language/Haskell/Liquid/Bare.hs b/src/Language/Haskell/Liquid/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Bare.hs @@ -0,0 +1,1739 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | This module contains the functions that convert /from/ descriptions of +-- symbols, names and types (over freshly parsed /bare/ Strings), +-- /to/ representations connected to GHC vars, names, and types. +-- The actual /representations/ of bare and real (refinement) types are all +-- in `RefType` -- they are different instances of `RType` + +module Language.Haskell.Liquid.Bare ( + GhcSpec (..) + , makeGhcSpec + ) where + +import ConLike +import GHC hiding (lookupName, Located) +import Text.PrettyPrint.HughesPJ hiding (first, (<>)) +import Var +import Name (getSrcSpan, isInternalName) +import NameSet +import Id (isConLikeId) +import CoreSyn hiding (Expr) +import PrelNames +import PrelInfo (wiredInThings) +import Type (expandTypeSynonyms, splitFunTy_maybe) +import DataCon (dataConWorkId, dataConStupidTheta) +import TyCon (SynTyConRhs(SynonymTyCon)) +import HscMain +import TysWiredIn +import BasicTypes (TupleSort (..), Arity) +import TcRnDriver (tcRnLookupRdrName) +import RdrName (setRdrNameSpace) +import OccName (tcName) +import Data.Char (isLower, isUpper) +import Text.Printf +-- import Data.Maybe (listToMaybe, fromMaybe, mapMaybe, catMaybes, isNothing, fromJust) +import Control.Monad.State (get, gets, modify, State, evalState, evalStateT, execState, StateT) +import Data.Traversable (forM) +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.Monad.Reader hiding (forM) +import Control.Monad.Error hiding (Error, forM) +import Control.Monad.Writer hiding (forM) +import qualified Control.Exception as Ex +import Data.Bifunctor +import Data.Generics.Aliases (mkT) +import Data.Generics.Schemes (everywhere) +-- import Data.Data hiding (TyCon, tyConName) +-- import Data.Function (on) +import qualified Data.Text as T +import Text.Parsec.Pos +import Language.Fixpoint.Misc +import Language.Fixpoint.Names (prims, hpropConName, propConName, takeModuleNames, dropModuleNames, isPrefixOfSym, dropSym, lengthSym, headSym, stripParensSym, takeWhileSym) +import Language.Fixpoint.Types hiding (Def, Predicate, R) +import Language.Fixpoint.Sort (checkSortFull, checkSortedReftFull, checkSorted) +import Language.Haskell.Liquid.GhcMisc hiding (L) +import Language.Haskell.Liquid.Misc +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.RefType +import Language.Haskell.Liquid.Errors +import Language.Haskell.Liquid.PredType hiding (unify) +import qualified Language.Haskell.Liquid.Measure as Ms + + +import Data.Maybe +import qualified Data.List as L +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import TypeRep + +import Debug.Trace (trace) + +------------------------------------------------------------------ +---------- Top Level Output -------------------------------------- +------------------------------------------------------------------ + +makeGhcSpec :: Config -> ModName -> [CoreBind] -> [Var] -> [Var] -> NameSet -> HscEnv + -> [(ModName,Ms.BareSpec)] + -> IO GhcSpec +makeGhcSpec cfg name cbs vars defVars exports env specs + + = throwOr (throwOr return . checkGhcSpec specs . postProcess cbs) =<< execBare act initEnv + where + act = makeGhcSpec' cfg vars defVars exports specs + throwOr = either Ex.throw + initEnv = BE name mempty mempty mempty env + +postProcess :: [CoreBind] -> GhcSpec -> GhcSpec +postProcess cbs sp@(SP {..}) = sp { tySigs = sigs, texprs = ts } + -- HEREHEREHEREHERE (addTyConInfo stuff) + where + (sigs, ts) = replaceLocalBinds tcEmbeds tyconEnv tySigs texprs (ghcSpecEnv sp) cbs + + +------------------------------------------------------------------------------------------------ +makeGhcSpec' :: Config -> [Var] -> [Var] -> NameSet -> [(ModName, Ms.BareSpec)] -> BareM GhcSpec +------------------------------------------------------------------------------------------------ +makeGhcSpec' cfg vars defVars exports specs + = do name <- gets modName + _ <- makeRTEnv specs + (tycons, datacons, dcSelectors, tyi) <- makeGhcSpecCHOP1 specs + modify $ \be -> be { tcEnv = tyi } + (cls, mts) <- second mconcat . unzip . mconcat <$> mapM (makeClasses cfg vars) specs + (invs, ialias, embs, sigs, asms) <- makeGhcSpecCHOP2 cfg vars defVars specs name cls mts + (measures, cms', ms', cs', xs') <- makeGhcSpecCHOP3 cfg vars specs dcSelectors datacons cls embs + syms <- makeSymbols (vars ++ map fst cs') xs' (sigs ++ asms ++ cs') ms' (invs ++ (snd <$> ialias)) + let su = mkSubst [ (x, mkVarExpr v) | (x, v) <- syms] + return (emptySpec cfg) + >>= makeGhcSpec0 cfg defVars exports name + >>= makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su + >>= makeGhcSpec2 invs ialias measures su + >>= makeGhcSpec3 datacons tycons embs syms + >>= makeGhcSpec4 defVars specs name su + +emptySpec :: Config -> GhcSpec +emptySpec cfg = SP [] [] [] [] [] [] [] [] [] mempty [] [] [] [] mempty mempty cfg mempty [] mempty + +makeGhcSpec0 cfg defVars exports name sp + = do targetVars <- makeTargetVars name defVars $ binders cfg + return $ sp { config = cfg + , exports = exports + , tgtVars = targetVars } + +makeGhcSpec1 vars embs tyi exports name sigs asms cs' ms' cms' su sp + = return $ sp { tySigs = makePluggedSigs name embs tyi exports $ tx sigs + , asmSigs = renameTyVars <$> tx asms + , ctors = tx cs' + , meas = tx $ ms' ++ varMeasures vars ++ cms' } + where + tx = fmap . mapSnd . subst $ su + +makeGhcSpec2 invs ialias measures su sp + = return $ sp { invariants = subst su invs + , ialiases = subst su ialias + , measures = subst su <$> M.elems $ Ms.measMap measures } + +makeGhcSpec3 datacons tycons embs syms sp + = do tcEnv <- gets tcEnv + return $ sp { tyconEnv = tcEnv + , dconsP = datacons + , tconsP = tycons + , tcEmbeds = embs + , freeSyms = [(symbol v, v) | (_, v) <- syms] } + +makeGhcSpec4 defVars specs name su sp + = do decr' <- mconcat <$> mapM (makeHints defVars) specs + texprs' <- mconcat <$> mapM (makeTExpr defVars) specs + lazies <- mkThing makeLazy + lvars' <- mkThing makeLVar + quals <- mconcat <$> mapM makeQualifiers specs + return $ sp { qualifiers = subst su quals + , decr = decr' + , texprs = texprs' + , lvars = lvars' + , lazy = lazies } + where + mkThing mk = S.fromList . mconcat <$> sequence [ mk defVars (m, s) | (m, s) <- specs, m == name ] + +makeGhcSpecCHOP1 specs + = do (tcs, dcs) <- mconcat <$> mapM makeConTypes specs + let tycons = tcs ++ wiredTyCons + let datacons = mapSnd val <$> (concat dcs ++ wiredDataCons) + let dcSelectors = concat $ map makeMeasureSelectors (concat dcs) + let tyi = makeTyConInfo tycons + return $ (tycons, datacons, dcSelectors, tyi) + +makeGhcSpecCHOP2 cfg vars defVars specs name cls mts + = do sigs' <- mconcat <$> mapM (makeAssertSpec name cfg vars defVars) specs + asms' <- mconcat <$> mapM (makeAssumeSpec name cfg vars defVars) specs + invs <- mconcat <$> mapM makeInvariants specs + ialias <- mconcat <$> mapM makeIAliases specs + embs <- mconcat <$> mapM makeTyConEmbeds specs + let dms = makeDefaultMethods vars mts + tyi <- gets tcEnv + let sigs = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (m, x, t) <- sigs' ++ mts ++ dms ] + let asms = [ (x, txRefSort tyi embs . txExpToBind <$> t) | (m, x, t) <- asms' ] + return (invs, ialias, embs, sigs, asms) + +makeGhcSpecCHOP3 cfg vars specs dcSelectors datacons cls embs + = do measures' <- mconcat <$> mapM makeMeasureSpec specs + tyi <- gets tcEnv + let measures = measures' `mappend` Ms.mkMSpec' dcSelectors + let (cs, ms) = makeMeasureSpec' measures + let cms = makeClassMeasureSpec measures + let cms' = [ (x, Loc l $ cSort t) | (Loc l x, t) <- cms ] + let ms' = [ (x, Loc l t) | (Loc l x, t) <- ms, isNothing $ lookup x cms' ] + let cs' = [ (v, Loc (getSourcePos v) (txRefSort tyi embs t)) | (v, t) <- meetDataConSpec cs (datacons ++ cls)] + let xs' = val . fst <$> ms + return (measures, cms', ms', cs', xs') + +makeMeasureSelectors :: (DataCon, Located DataConP) -> [Measure SpecType DataCon] +makeMeasureSelectors (dc, (Loc loc (DataConP _ vs _ _ _ xts r))) = go <$> zip (reverse xts) [1..] + where + go ((x,t), i) = makeMeasureSelector (Loc loc x) (dty t) dc n i + + dty t = foldr RAllT (RFun dummySymbol r (fmap mempty t) mempty) vs + n = length xts + + +makePluggedSigs name embs tcEnv exports sigs + = [ (x, plugHoles embs tcEnv x r τ t) + | (x, t) <- sigs + , let τ = expandTypeSynonyms $ varType x + , let r = maybeTrue x name exports + ] + + + +makeMeasureSelector x s dc n i = M {name = x, sort = s, eqns = [eqn]} + where eqn = Def x dc (mkx <$> [1 .. n]) (E (EVar $ mkx i)) + mkx j = symbol ("xx" ++ show j) + +--- Refinement Type Aliases +makeRTEnv specs + = do forM_ rts $ \(mod, rta) -> setRTAlias (rtName rta) $ Left (mod, rta) + forM_ pts $ \(mod, pta) -> setRPAlias (rtName pta) $ Left (mod, pta) + makeRPAliases pts + makeRTAliases rts + where + rts = (concat [(m,) <$> Ms.aliases s | (m, s) <- specs]) + pts = (concat [(m,) <$> Ms.paliases s | (m, s) <- specs]) + +makeRTAliases xts = mapM_ expBody xts + where + expBody (mod,xt) = inModule mod $ do + let l = rtPos xt + body <- withVArgs l (rtVArgs xt) $ expandRTAlias l $ rtBody xt + setRTAlias (rtName xt) $ Right $ mapRTAVars symbolRTyVar $ xt { rtBody = body } + +makeRPAliases xts = mapM_ expBody xts + where + expBody (mod, xt) = inModule mod $ do + let l = rtPos xt + env <- gets $ predAliases . rtEnv + body <- withVArgs l (rtVArgs xt) $ expandRPAliasE l $ rtBody xt + setRPAlias (rtName xt) $ Right $ xt { rtBody = body } + +-- | Using the Alias Environment to Expand Definitions +expandRTAliasMeasure m + = do eqns <- sequence $ expandRTAliasDef <$> (eqns m) + return $ m { sort = generalize (sort m) + , eqns = eqns } + +expandRTAliasDef :: Def LocSymbol -> BareM (Def LocSymbol) +expandRTAliasDef d + = do env <- gets rtEnv + body <- expandRTAliasBody (loc $ measure d) env $ body d + return $ d { body = body } + +expandRTAliasBody :: SourcePos -> RTEnv -> Body -> BareM Body +expandRTAliasBody l env (P p) = P <$> expPAlias l p +expandRTAliasBody l env (R x p) = R x <$> expPAlias l p +expandRTAliasBody l _ (E e) = E <$> resolve l e + +expPAlias :: SourcePos -> Pred -> BareM Pred +expPAlias l = expandPAlias l [] + + +expandRTAlias :: SourcePos -> BareType -> BareM SpecType +expandRTAlias l bt = expType =<< expReft bt + where + expReft = mapReftM (txPredReft expPred) + expType = expandAlias l [] + expPred = expandPAlias l [] + +txPredReft :: (Pred -> BareM Pred) -> RReft -> BareM RReft +txPredReft f (U r p l) = (\r -> U r p l) <$> txPredReft' f r + where + txPredReft' f (Reft (v, ras)) = Reft . (v,) <$> mapM (txPredRefa f) ras + txPredRefa f (RConc p) = RConc <$> f p + txPredRefa _ z = return z + +-- | Using the Alias Environment to Expand Definitions + +expandRPAliasE l = expandPAlias l [] + +expandAlias :: SourcePos -> [Symbol] -> BareType -> BareM SpecType +expandAlias l = go + where + go s t@(RApp (Loc _ c) _ _ _) + | c `elem` s = Ex.throw $ errOther $ text + $ "Cyclic Reftype Alias Definition: " ++ show (c:s) + | otherwise = lookupExpandRTApp l s t + go s (RVar a r) = RVar (symbolRTyVar a) <$> resolve l r + go s (RFun x t t' r) = rFun x <$> go s t <*> go s t' + go s (RAppTy t t' r) = RAppTy <$> go s t <*> go s t' <*> resolve l r + go s (RAllE x t1 t2) = liftM2 (RAllE x) (go s t1) (go s t2) + go s (REx x t1 t2) = liftM2 (REx x) (go s t1) (go s t2) + go s (RAllT a t) = RAllT (symbolRTyVar a) <$> go s t + go s (RAllP a t) = RAllP <$> ofBPVar a <*> go s t + go s (RAllS l t) = RAllS l <$> go s t + go s (RCls c ts) = RCls <$> lookupGhcClass c <*> mapM (go s) ts + go _ (ROth s) = return $ ROth s + go _ (RExprArg e) = return $ RExprArg e + go _ (RHole r) = RHole <$> resolve l r + + +lookupExpandRTApp l s (RApp lc@(Loc _ c) ts rs r) = do + env <- gets (typeAliases.rtEnv) + case M.lookup c env of + Just (Left (mod,rtb)) -> do + st <- inModule mod $ withVArgs l (rtVArgs rtb) $ expandAlias l (c:s) $ rtBody rtb + let rts = mapRTAVars symbolRTyVar $ rtb { rtBody = st } + setRTAlias c $ Right rts + r' <- resolve l r + expandRTApp l s rts ts r' + Just (Right rts) -> do + r' <- resolve l r + withVArgs l (rtVArgs rts) $ expandRTApp l s rts ts r' + Nothing + | isList c && length ts == 1 -> do + tyi <- tcEnv <$> get + r' <- resolve l r + liftM2 (bareTCApp tyi r' listTyCon) (mapM (go s) rs) (mapM (expandAlias l s) ts) + | isTuple c -> do + tyi <- tcEnv <$> get + r' <- resolve l r + let tc = tupleTyCon BoxedTuple (length ts) + liftM2 (bareTCApp tyi r' tc) (mapM (go s) rs) (mapM (expandAlias l s) ts) + | otherwise -> do + tyi <- tcEnv <$> get + r' <- resolve l r + liftM3 (bareTCApp tyi r') (lookupGhcTyCon lc) (mapM (go s) rs) (mapM (expandAlias l s) ts) + where + go s (RPropP ss r) = RPropP <$> mapM ofSyms ss <*> resolve l r + go s (RProp ss t) = RProp <$> mapM ofSyms ss <*> expandAlias l s t + go _ (RHProp _ _) = errorstar "TODO:EFFECTS:lookupExpandRTApp" + +expandRTApp :: SourcePos -> [Symbol] -> RTAlias RTyVar SpecType -> [BareType] -> RReft -> BareM SpecType +expandRTApp l s rta args r + | length args == (length αs) + (length εs) + = do args' <- mapM (expandAlias l s) args + let ts = take (length αs) args' + αts = zipWith (\α t -> (α, toRSort t, t)) αs ts + return $ subst su . (`strengthen` r) . subsTyVars_meet αts $ rtBody rta + | otherwise + = errortext $ (text msg) + where + su = mkSubst $ zip (symbol <$> εs) es + αs = rtTArgs rta + εs = rtVArgs rta +-- msg = rtName rta ++ " " ++ join (map showpp args) + es_ = drop (length αs) args + es = map (exprArg msg) es_ + msg = "Malformed type alias application at " ++ show l ++ "\n\t" + ++ show (rtName rta) + ++ " defined at " ++ show (rtPos rta) + ++ "\n\texpects " ++ show (length αs + length εs) + ++ " arguments but it is given " ++ show (length args) +-- | exprArg converts a tyVar to an exprVar because parser cannot tell +-- HORRIBLE HACK To allow treating upperCase X as value variables X +-- e.g. type Matrix a Row Col = List (List a Row) Col + +exprArg _ (RExprArg e) + = e +exprArg _ (RVar x _) + = EVar (symbol x) +exprArg _ (RApp x [] [] _) + = EVar (symbol x) +exprArg msg (RApp f ts [] _) + = EApp (symbol <$> f) (exprArg msg <$> ts) +exprArg msg (RAppTy (RVar f _) t _) + = EApp (dummyLoc $ symbol f) [exprArg msg t] +exprArg msg z + = errorstar $ printf "Unexpected expression parameter: %s in %s" (show z) msg + +expandPAlias :: SourcePos -> [Symbol] -> Pred -> BareM Pred +expandPAlias l = go + where + go s p@(PBexp (EApp f@(Loc l' f') es)) + | f' `elem` s = errorstar $ "Cyclic Predicate Alias Definition: " ++ show (f':s) + | otherwise = do + env <- gets (predAliases.rtEnv) + case M.lookup f' env of + Just (Left (mod,rp)) -> do + body <- inModule mod $ withVArgs l' (rtVArgs rp) $ expandPAlias l' (f':s) $ rtBody rp + let rp' = rp { rtBody = body } + setRPAlias f' $ Right $ rp' + expandRPApp l (f':s) rp' <$> resolve l es + Just (Right rp) -> + withVArgs l (rtVArgs rp) (expandRPApp l (f':s) rp <$> resolve l es) + Nothing -> fmap PBexp (EApp <$> resolve l f <*> resolve l es) + go s (PAnd ps) = PAnd <$> (mapM (go s) ps) + go s (POr ps) = POr <$> (mapM (go s) ps) + go s (PNot p) = PNot <$> (go s p) + go s (PImp p q) = PImp <$> (go s p) <*> (go s q) + go s (PIff p q) = PIff <$> (go s p) <*> (go s q) + go s (PAll xts p) = PAll xts <$> (go s p) + go _ p = resolve l p + +expandRPApp l s rp es + = let su = mkSubst $ safeZipWithError msg (rtVArgs rp) es + msg = "Malformed alias application at " ++ show l ++ "\n\t" + ++ show (rtName rp) + ++ " defined at " ++ show (rtPos rp) + ++ "\n\texpects " ++ show (length $ rtVArgs rp) + ++ " arguments but it is given " ++ show (length es) +-- msg = "expandRPApp: " ++ show (EApp (dummyLoc $ symbol $ rtName rp) es) + in subst su $ rtBody rp + + +makeQualifiers (mod,spec) = inModule mod mkQuals + where + mkQuals = -- resolve dummyPos $ Ms.qualifiers spec + mapM (\q -> resolve (q_pos q) q) $ Ms.qualifiers spec + + +makeClasses cfg vs (mod, spec) = inModule mod $ mapM mkClass $ Ms.classes spec + where + --FIXME: cleanup this code + unClass = snd . bkClass . fourth4 . bkUniv + mkClass (RClass c ss as ms) + = do let l = loc c + tc <- lookupGhcTyCon c + ss' <- mapM (mkSpecType l) ss + let (dc:_) = tyConDataCons tc + let αs = map symbolRTyVar as + let as' = [rVar $ symbolTyVar a | a <- as ] + let ms' = [ (s, rFun "" (RCls c (flip RVar mempty <$> as)) t) | (s, t) <- ms] + vts <- makeSpec cfg vs ms' + let sts = [(val s, unClass $ val t) | (s, _) <- ms + | (_, _, t) <- vts] + let t = RCls (fromJust $ tyConClass_maybe tc) as' + let dcp = DataConP l αs [] [] ss' (reverse sts) t + return ((dc,dcp),vts) + +makeHints vs (_, spec) = varSymbols id "Hint" vs $ Ms.decr spec +makeLVar vs (_, spec) = fmap fst <$> (varSymbols id "LazyVar" vs $ [(v, ()) | v <- Ms.lvars spec]) +makeLazy vs (_, spec) = fmap fst <$> (varSymbols id "Lazy" vs $ [(v, ()) | v <- S.toList $ Ms.lazy spec]) +makeTExpr vs (_, spec) = varSymbols id "TermExpr" vs $ Ms.termexprs spec + +varSymbols :: ([Var] -> [Var]) -> Symbol -> [Var] -> [(LocSymbol, a)] -> BareM [(Var, a)] +varSymbols f n vs = concatMapM go + where lvs = M.map L.sort $ group [(sym v, locVar v) | v <- vs] + sym = dropModuleNames . symbol . showPpr + locVar v = (getSourcePos v, v) + go (s, ns) = case M.lookup (val s) lvs of + Just lvs -> return ((, ns) <$> varsAfter f s lvs) + Nothing -> ((:[]).(,ns)) <$> lookupGhcVar s + msg s = printf "%s: %s for Undefined Var %s" + (symbolString n) (show (loc s)) (show (val s)) + +varsAfter f s lvs + | eqList (fst <$> lvs) = f (snd <$> lvs) + | otherwise = map snd $ takeEqLoc $ dropLeLoc lvs + where + takeEqLoc xs@((l, _):_) = L.takeWhile ((l==) . fst) xs + takeEqLoc [] = [] + dropLeLoc = L.dropWhile ((loc s >) . fst) + eqList [] = True + eqList (x:xs) = all (==x) xs + +-- EFFECTS: TODO is this the SAME as addTyConInfo? No. `txRefSort` +-- (1) adds the _real_ sorts to RProp, +-- (2) gathers _extra_ RProp at turnst them into refinements, +-- e.g. tests/pos/multi-pred-app-00.hs +txRefSort tyi tce = mapBot (addSymSort tce tyi) + +addSymSort tce tyi t@(RApp rc@(RTyCon c _ _) ts rs r) + = RApp rc ts (zipWith addSymSortRef pvs rargs) r' + where + rc' = appRTyCon tce tyi rc ts + pvs = rTyConPVs rc' + rs' = zipWith addSymSortRef pvs rargs + (rargs, rrest) = splitAt (length pvs) rs + r' = L.foldl' go r rrest + go r (RPropP _ r') = r' `meet` r + go _ (RHProp _ _ ) = errorstar "TODO:EFFECTS:addSymSort" + go r _ = errorstar "YUCKER" -- r + +addSymSort _ _ t + = t + +addSymSortRef _ (RHProp _ _) = errorstar "TODO:EFFECTS:addSymSortRef" +addSymSortRef p r | isPropPV p = addSymSortRef' p r + | otherwise = errorstar "addSymSortRef: malformed ref application" + + +addSymSortRef' p (RProp s (RVar v r)) | isDummy v + = RProp xs t + where + t = ofRSort (pvType p) `strengthen` r + xs = spliceArgs "addSymSortRef 1" s p + +addSymSortRef' p (RProp s t) + = RProp xs t + where + xs = spliceArgs "addSymSortRef 2" s p + +-- EFFECTS: why can't we replace the next two equations with (breaks many tests) +-- +-- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ ptxs) (RPropP s r@(U _ (Pr [up]) _)) +-- EFFECTS: = RProp xts $ (ofRSort t) `strengthen` r +-- EFFECTS: where +-- EFFECTS: xts = safeZip "addRefSortMono" xs ts +-- EFFECTS: xs = snd3 <$> pargs up +-- EFFECTS: ts = fst3 <$> ptxs +-- +-- EFFECTS: addSymSortRef' (PV _ (PVProp t) _ _) (RPropP s r) +-- EFFECTS: = RProp s $ (ofRSort t) `strengthen` r + +addSymSortRef' p (RPropP s r@(U _ (Pr [up]) _)) + = RPropP xts r + where + xts = safeZip "addRefSortMono" xs ts + xs = snd3 <$> pargs up + ts = fst3 <$> pargs p + +addSymSortRef' p (RPropP s r) + = RPropP s r + +addSymSortRef' _ _ + = errorstar "TODO:EFFECTS:addSymSortRef'" + +spliceArgs msg s p = safeZip msg (fst <$> s) (fst3 <$> pargs p) +varMeasures vars = [ (symbol v, varSpecType v) | v <- vars, isDataConWorkId v, isSimpleType $ varType v ] +varSpecType v = Loc (getSourcePos v) (ofType $ varType v) +isSimpleType t = null tvs && isNothing (splitFunTy_maybe tb) where (tvs, tb) = splitForAllTys t + +------------------------------------------------------------------------------- +-- Renaming Type Variables in Haskell Signatures ------------------------------ +------------------------------------------------------------------------------- + +-- This throws an exception if there is a mismatch +-- renameTyVars :: (Var, SpecType) -> (Var, SpecType) +renameTyVars (x, lt@(Loc l t)) = (x, Loc l $ mkUnivs (rTyVar <$> αs) [] [] t') + where + t' = subts su $ mkUnivs [] ps ls tbody + su = [(y, rTyVar x) | (x, y) <- tyvsmap] + tyvsmap = vmap $ execState (mapTyVars τbody tbody) initvmap + initvmap = initMapSt err + (αs, τbody) = splitForAllTys $ expandTypeSynonyms $ varType x + (as, ps, ls, tbody) = bkUniv t + err = errTypeMismatch x lt + + +data MapTyVarST = MTVST { vmap :: [(Var, RTyVar)] + , errmsg :: Error + } + +initMapSt = MTVST [] + +mapTyVars :: (PPrint r, Reftable r) => Type -> RRType r -> State MapTyVarST () +mapTyVars τ (RAllT a t) + = mapTyVars τ t +mapTyVars (ForAllTy α τ) t + = mapTyVars τ t +mapTyVars (FunTy τ τ') (RFun _ t t' _) + = mapTyVars τ t >> mapTyVars τ' t' +mapTyVars (TyConApp _ τs) (RApp _ ts _ _) + = zipWithM_ mapTyVars τs ts +mapTyVars (TyVarTy α) (RVar a _) + = modify $ \s -> mapTyRVar α a s +mapTyVars τ (RAllP _ t) + = mapTyVars τ t +mapTyVars τ (RAllS _ t) + = mapTyVars τ t +mapTyVars τ (RCls _ ts) + = return () +mapTyVars τ (RAllE _ _ t) + = mapTyVars τ t +mapTyVars τ (REx _ _ t) + = mapTyVars τ t +mapTyVars τ (RExprArg _) + = return () +mapTyVars (AppTy τ τ') (RAppTy t t' _) + = do mapTyVars τ t + mapTyVars τ' t' +mapTyVars τ (RHole _) + = return () +mapTyVars τ t + = Ex.throw =<< errmsg <$> get + +mapTyRVar α a s@(MTVST αas err) + = case lookup α αas of + Just a' | a == a' -> s + | otherwise -> Ex.throw err + Nothing -> MTVST ((α,a):αas) err + +mkVarExpr v + | isFunVar v = EApp (varFunSymbol v) [] + | otherwise = EVar (symbol v) + +varFunSymbol = dummyLoc . dataConSymbol . idDataCon + +isFunVar v = isDataConWorkId v && not (null αs) && isNothing tf + where + (αs, t) = splitForAllTys $ varType v + tf = splitFunTy_maybe t + +-- meetDataConSpec :: [(Var, SpecType)] -> [(DataCon, DataConP)] -> [(Var, SpecType)] +meetDataConSpec xts dcs = M.toList $ L.foldl' upd dcm xts + where + dcm = M.fromList $ dataConSpec dcs + upd dcm (x, t) = M.insert x (maybe t (meetPad t) (M.lookup x dcm)) dcm + strengthen (x,t) = (x, maybe t (meetPad t) (M.lookup x dcm)) + + +-- dataConSpec :: [(DataCon, DataConP)] -> [(Var, SpecType)] +dataConSpec :: [(DataCon, DataConP)]-> [(Var, (RType Class RTyCon RTyVar RReft))] +dataConSpec dcs = concatMap mkDataConIdsTy [(dc, dataConPSpecType dc t) | (dc, t) <- dcs] + +meetPad t1 t2 = -- traceShow ("meetPad: " ++ msg) $ + case (bkUniv t1, bkUniv t2) of + ((_, π1s, ls1, _), (α2s, [], ls2, t2')) -> meet t1 (mkUnivs α2s π1s (ls1 ++ ls2) t2') + ((α1s, [], ls1, t1'), (_, π2s, ls2, _)) -> meet (mkUnivs α1s π2s (ls1 ++ ls2) t1') t2 + _ -> errorstar $ "meetPad: " ++ msg + where msg = "\nt1 = " ++ showpp t1 ++ "\nt2 = " ++ showpp t2 + +----------------------------------------------------------------------------------- +-- | Error-Reader-IO For Bare Transformation -------------------------------------- +----------------------------------------------------------------------------------- + +type BareM a = WriterT [Warn] (ErrorT Error (StateT BareEnv IO)) a + +type Warn = String + +type TCEnv = M.HashMap TyCon RTyCon + +data BareEnv = BE { modName :: !ModName + , tcEnv :: !TCEnv + , rtEnv :: !RTEnv + , varEnv :: ![(Symbol,Var)] + , hscEnv :: HscEnv } + +setModule m b = b { modName = m } + +inModule m act = do + old <- gets modName + modify $ setModule m + res <- act + modify $ setModule old + return res + +withVArgs l vs act = do + old <- gets rtEnv + mapM (mkExprAlias l . symbol . showpp) vs + res <- act + modify $ \be -> be { rtEnv = old } + return res + +addSym x = modify $ \be -> be { varEnv = (varEnv be) `L.union` [x] } + +mkExprAlias l v + = setRTAlias v (Right (RTA v [] [] (RExprArg (EVar $ symbol v)) l)) + +setRTAlias s a = + modify $ \b -> b { rtEnv = mapRT (M.insert s a) $ rtEnv b } + +setRPAlias s a = + modify $ \b -> b { rtEnv = mapRP (M.insert s a) $ rtEnv b } + +------------------------------------------------------------------ +execBare :: BareM a -> BareEnv -> IO (Either Error a) +------------------------------------------------------------------ +execBare act benv = + do z <- evalStateT (runErrorT (runWriterT act)) benv + case z of + Left s -> return $ Left s + Right (x, ws) -> do forM_ ws $ putStrLn . ("WARNING: " ++) + return $ Right x + +------------------------------------------------------------------ +-- | API: Bare Refinement Types ---------------------------------- +------------------------------------------------------------------ + +makeMeasureSpec :: (ModName, Ms.Spec BareType LocSymbol) -> BareM (Ms.MSpec SpecType DataCon) +makeMeasureSpec (mod,spec) = inModule mod mkSpec + where + mkSpec = mkMeasureDCon =<< mkMeasureSort =<< m + m = Ms.mkMSpec <$> (mapM expandRTAliasMeasure $ Ms.measures spec) + <*> return (Ms.cmeasures spec) + <*> (mapM expandRTAliasMeasure $ Ms.imeasures spec) + +makeMeasureSpec' = mapFst (mapSnd uRType <$>) . Ms.dataConTypes . first (mapReft ur_reft) + +makeClassMeasureSpec (Ms.MSpec {..}) = tx <$> M.elems cmeasMap + where + tx (M n s _) = (n, CM n (mapReft ur_reft s) -- [(t,m) | (IM n' t m) <- imeas, n == n'] + ) + +makeTargetVars :: ModName -> [Var] -> [String] -> BareM [Var] +makeTargetVars name vs ss + = do env <- gets hscEnv + ns <- liftIO $ concatMapM (lookupName env name . dummyLoc . prefix) ss + return $ filter ((`elem` ns) . varName) vs + where + prefix s = qualifySymbol (symbol name) (symbol s) + + +makeAssertSpec cmod cfg vs lvs (mod,spec) + | cmod == mod + = makeLocalSpec cfg cmod vs lvs (Ms.sigs spec ++ Ms.localSigs spec) + | otherwise + = inModule mod $ makeSpec cfg vs $ Ms.sigs spec + +makeAssumeSpec cmod cfg vs lvs (mod,spec) + | cmod == mod + = makeLocalSpec cfg cmod vs lvs $ Ms.asmSigs spec + | otherwise + = inModule mod $ makeSpec cfg vs $ Ms.asmSigs spec + +makeDefaultMethods :: [Var] -> [(ModName,Var,Located SpecType)] + -> [(ModName,Var,Located SpecType)] +makeDefaultMethods defVs sigs + = [ (m,dmv,t) + | dmv <- defVs + , let dm = symbol $ showPpr dmv + , "$dm" `isPrefixOfSym` (dropModuleNames dm) + , let mod = takeModuleNames dm + , let method = qualifySymbol mod $ dropSym 3 (dropModuleNames dm) + , let mb = L.find ((method `isPrefixOfSym`) . symbol . snd3) sigs + , isJust mb + , let Just (m,_,t) = mb + ] + +makeLocalSpec :: Config -> ModName -> [Var] -> [Var] -> [(LocSymbol, BareType)] + -> BareM [(ModName, Var, Located SpecType)] +makeLocalSpec cfg mod vs lvs xbs + = do env <- get + vbs1 <- fmap expand3 <$> varSymbols fchoose "Var" lvs (dupSnd <$> xbs1) + unless (noCheckUnknown cfg) $ checkDefAsserts env vbs1 xbs1 + vts1 <- map (addFst3 mod) <$> mapM mkVarSpec vbs1 + vts2 <- makeSpec cfg vs xbs2 + return $ vts1 ++ vts2 + where + (xbs1, xbs2) = L.partition (modElem mod . fst) xbs + dupSnd (x, y) = (dropMod x, (x, y)) + expand3 (x, (y, w)) = (x, y, w) + dropMod = fmap (dropModuleNames . symbol) + fchoose ls = maybe ls (:[]) $ L.find (`elem` vs) ls + modElem n x = (takeModuleNames $ val x) == (symbol n) + +makeSpec :: Config -> [Var] -> [(LocSymbol, BareType)] + -> BareM [(ModName, Var, Located SpecType)] +makeSpec cfg vs xbs + = do vbs <- map (joinVar vs) <$> lookupIds xbs + env@(BE { modName = mod}) <- get + unless (noCheckUnknown cfg) $ checkDefAsserts env vbs xbs + map (addFst3 mod) <$> mapM mkVarSpec vbs + +-- the Vars we lookup in GHC don't always have the same tyvars as the Vars +-- we're given, so return the original var when possible. +-- see tests/pos/ResolvePred.hs for an example +joinVar vs (v,s,t) = case L.find ((== showPpr v) . showPpr) vs of + Just v' -> (v',s,t) + Nothing -> (v,s,t) + +lookupIds = mapM lookup + where + lookup (s, t) = (,s,t) <$> lookupGhcVar s + +checkDefAsserts :: BareEnv -> [(Var, LocSymbol, BareType)] -> [(LocSymbol, BareType)] -> BareM () +checkDefAsserts env vbs xbs = applyNonNull (return ()) grumble undefSigs + where + undefSigs = [x | (x, _) <- assertSigs, not (x `S.member` definedSigs)] + assertSigs = filter isTarget xbs + definedSigs = S.fromList $ snd3 <$> vbs + grumble = mapM_ (warn . berrUnknownVar) + moduleName = symbol $ modName env + isTarget = isPrefixOfSym moduleName . stripParensSym . val . fst + +warn x = tell [x] + + +mkVarSpec :: (Var, LocSymbol, BareType) -> BareM (Var, Located SpecType) +mkVarSpec (v, Loc l _, b) = tx <$> mkSpecType l b + where + tx = (v,) . Loc l . generalize + +plugHoles tce tyi x f t (Loc l st) = Loc l $ mkArrow αs ps' (ls1 ++ ls2) cs' $ go rt' st''' + where + (αs, _, ls1, rt) = bkUniv (ofType t :: SpecType) + (cs, rt') = bkClass rt + + (_, ps, ls2, st') = bkUniv st + (_, st'') = bkClass st' + cs' = [(dummySymbol, RCls c t) | (c,t) <- cs] + + tyvsmap = vmap $ execState (mapTyVars (toType rt') st'') initvmap + initvmap = initMapSt $ ErrMismatch (sourcePosSrcSpan l) (pprint x) t st + su = [(y, rTyVar x) | (x, y) <- tyvsmap] + st''' = subts su st'' + ps' = fmap (subts su') <$> ps + su' = [(y, RVar (rTyVar x) ()) | (x, y) <- tyvsmap] :: [(RTyVar, RSort)] + + go t (RHole r) = (addHoles t') { rt_reft = f r } + where + t' = everywhere (mkT $ addRefs tce tyi) t + addHoles = fmap (const $ f $ uReft ("v", [hole])) + go (RVar _ _) v@(RVar _ _) = v + go (RFun _ i o _) (RFun x i' o' r) = RFun x (go i i') (go o o') r + go (RAllT _ t) (RAllT a t') = RAllT a $ go t t' + go t (RAllE b a t') = RAllE b a $ go t t' + go t (REx b x t') = REx b x $ go t t' + go (RAppTy t1 t2 _) (RAppTy t1' t2' r) = RAppTy (go t1 t1') (go t2 t2') r + go (RApp _ t _ _) (RApp c t' p r) = RApp c (zipWith go t t') p r + go (RCls _ t) (RCls c t') = RCls c $ zipWith go t t' + go t st = Ex.throw err + where + err = errOther $ text msg + msg = printf "plugHoles: unhandled case!\nt = %s\nst = %s\n" (showpp t) (showpp st) + +addRefs :: TCEmb TyCon + -> M.HashMap TyCon RTyCon + -> SpecType + -> SpecType +addRefs tce tyi (RApp c ts _ r) = RApp c' ts ps r + where + RApp c' _ ps _ = addTyConInfo tce tyi (RApp c ts [] r) + ps' = safeZip "addRefHoles" ps (rTyConPVs c') +addRefs _ _ t = t + +showTopLevelVars vs = + forM vs $ \v -> + when (isExportedId v) $ + donePhase Loud ("Exported: " ++ showPpr v) + +---------------------------------------------------------------------- + +makeTyConEmbeds (mod, spec) + = inModule mod $ makeTyConEmbeds' $ Ms.embeds spec + +makeTyConEmbeds' :: TCEmb (Located Symbol) -> BareM (TCEmb TyCon) +makeTyConEmbeds' z = M.fromList <$> mapM tx (M.toList z) + where + tx (c, y) = (, y) <$> lookupGhcTyCon c + +makeIAliases (mod, spec) + = inModule mod $ makeIAliases' $ Ms.ialiases spec + +makeIAliases' :: [(Located BareType, Located BareType)] -> BareM [(Located SpecType, Located SpecType)] +makeIAliases' ts = mapM mkIA ts + where + mkIA (t1, t2) = liftM2 (,) (mkI t1) (mkI t2) + mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t + +makeInvariants (mod,spec) + = inModule mod $ makeInvariants' $ Ms.invariants spec + +makeInvariants' :: [Located BareType] -> BareM [Located SpecType] +makeInvariants' ts = mapM mkI ts + where + mkI (Loc l t) = (Loc l) . generalize <$> mkSpecType l t + +mkSpecType l t = mkSpecType' l (ty_preds $ toRTypeRep t) t + +mkSpecType' :: SourcePos -> [PVar BSort] -> BareType -> BareM SpecType +mkSpecType' l πs = expandRTAlias l . txParams subvUReft (uPVar <$> πs) + +-- WTF does this function do? +makeSymbols vs xs' xts yts ivs + = do svs <- gets varEnv + return [ (x,v') | (x,v) <- svs, x `elem` xs, let (v',_,_) = joinVar vs (v,x,x)] + where + xs = sortNub $ zs ++ zs' ++ zs'' + zs = concatMap freeSymbols (snd <$> xts) `sortDiff` xs' + zs' = concatMap freeSymbols (snd <$> yts) `sortDiff` xs' + zs'' = concatMap freeSymbols ivs `sortDiff` xs' + +freeSymbols ty = sortNub $ concat $ efoldReft (\_ _ -> []) (\ _ -> ()) f (\_ -> id) emptySEnv [] (val ty) + where + f γ _ r xs = let Reft (v, _) = toReft r in + [ x | x <- syms r, x /= v, not (x `memberSEnv` γ)] : xs + +----------------------------------------------------------------- +------ Querying GHC for Id, Type, Class, Con etc. --------------- +----------------------------------------------------------------- + +class Symbolic a => GhcLookup a where + lookupName :: HscEnv -> ModName -> a -> IO [Name] + srcSpan :: a -> SrcSpan + +instance GhcLookup (Located Symbol) where + lookupName e m = symbolLookup e m . val + srcSpan = sourcePosSrcSpan . loc + +instance GhcLookup Name where + lookupName _ _ = return . (:[]) + srcSpan = nameSrcSpan + +-- lookupGhcThing :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM b +lookupGhcThing name f x + = do zs <- lookupGhcThing' name f x + case zs of + Just x' -> return x' + Nothing -> throwError $ ErrGhc (srcSpan x) (text msg) + where + msg = "Not in scope: " ++ name ++ " `" ++ symbolString (symbol x) ++ "'" + +-- lookupGhcThing' :: (GhcLookup a) => String -> (TyThing -> Maybe b) -> a -> BareM (Maybe b) +lookupGhcThing' _ f x + = do (BE mod _ _ _ env) <- get + ns <- liftIO $ lookupName env mod x + mts <- liftIO $ mapM (fmap (join . fmap f) . hscTcRcLookupName env) ns + case catMaybes mts of + [] -> return Nothing + (t:_) -> return $ Just t + +symbolLookup :: HscEnv -> ModName -> Symbol -> IO [Name] +symbolLookup env mod k + | k `M.member` wiredIn + = return $ maybeToList $ M.lookup k wiredIn + | otherwise + = symbolLookupEnv env mod k + +symbolLookupEnv env mod s + | isSrcImport mod + = do let modName = getModName mod + L _ rn <- hscParseIdentifier env $ symbolString s + res <- lookupRdrName env modName rn + -- 'hscParseIdentifier' defaults constructors to 'DataCon's, but we also + -- need to get the 'TyCon's for declarations like @data Foo = Foo Int@. + res' <- lookupRdrName env modName (setRdrNameSpace rn tcName) + return $ catMaybes [res, res'] + | otherwise + = do L _ rn <- hscParseIdentifier env $ symbolString s + (_, lookupres) <- tcRnLookupRdrName env rn + case lookupres of + Just ns -> return ns + _ -> return [] + +-- | It's possible that we have already resolved the 'Name' we are looking for, +-- but have had to turn it back into a 'String', e.g. to be used in an 'Expr', +-- as in @{v:Ordering | v = EQ}@. In this case, the fully-qualified 'Name' +-- (@GHC.Types.EQ@) will likely not be in scope, so we store our own mapping of +-- fully-qualified 'Name's to 'Var's and prefer pulling 'Var's from it. +lookupGhcVar :: GhcLookup a => a -> BareM Var +lookupGhcVar x + = do env <- gets varEnv + case L.lookup (symbol x) env of + Nothing -> lookupGhcThing "variable" fv x + Just v -> return v + where + fv (AnId x) = Just x + fv (AConLike (RealDataCon x)) = Just $ dataConWorkId x + fv _ = Nothing + +lookupGhcTyCon :: GhcLookup a => a -> BareM TyCon +lookupGhcTyCon s = (lookupGhcThing "type constructor or class" ftc s) + `catchError` (tryPropTyCon s) + where + ftc (ATyCon x) = Just x + ftc _ = Nothing + +tryPropTyCon s e + | sx == propConName = return propTyCon + | sx == hpropConName = return hpropTyCon + | otherwise = throwError e + where + sx = symbol s + +lookupGhcClass = lookupGhcThing "class" ftc + where + ftc (ATyCon x) = tyConClass_maybe x + ftc _ = Nothing + +lookupGhcDataCon dc = case isTupleDC $ val dc of + Just n -> return $ tupleCon BoxedTuple n + Nothing -> lookupGhcDataCon' dc + +isTupleDC zs + | "(," `isPrefixOfSym` zs + = Just $ lengthSym zs - 1 + | otherwise + = Nothing + +lookupGhcDataCon' = lookupGhcThing "data constructor" fdc + where + fdc (AConLike (RealDataCon x)) = Just x + fdc _ = Nothing + +wiredIn :: M.HashMap Symbol Name +wiredIn = M.fromList $ special ++ wiredIns + where + wiredIns = [ (symbol n, n) | thing <- wiredInThings, let n = getName thing ] + special = [ ("GHC.Integer.smallInteger", smallIntegerName) + , ("GHC.Num.fromInteger" , fromIntegerName ) ] + +class Resolvable a where + resolve :: SourcePos -> a -> BareM a + +instance Resolvable a => Resolvable [a] where + resolve = mapM . resolve + +instance Resolvable Qualifier where + resolve _ (Q n ps b l) = Q n <$> mapM (secondM (resolve l)) ps <*> resolve l b <*> return l + +instance Resolvable Pred where + resolve l (PAnd ps) = PAnd <$> resolve l ps + resolve l (POr ps) = POr <$> resolve l ps + resolve l (PNot p) = PNot <$> resolve l p + resolve l (PImp p q) = PImp <$> resolve l p <*> resolve l q + resolve l (PIff p q) = PIff <$> resolve l p <*> resolve l q + resolve l (PBexp b) = PBexp <$> resolve l b + resolve l (PAtom r e1 e2) = PAtom r <$> resolve l e1 <*> resolve l e2 + resolve l (PAll vs p) = PAll <$> mapM (secondM (resolve l)) vs <*> resolve l p + resolve _ p = return p + +instance Resolvable Expr where + resolve l (EVar s) = EVar <$> resolve l s + resolve l (EApp s es) = EApp <$> resolve l s <*> resolve l es + resolve l (EBin o e1 e2) = EBin o <$> resolve l e1 <*> resolve l e2 + resolve l (EIte p e1 e2) = EIte <$> resolve l p <*> resolve l e1 <*> resolve l e2 + resolve l (ECst x s) = ECst <$> resolve l x <*> resolve l s + resolve l x = return x + +instance Resolvable LocSymbol where + resolve _ ls@(Loc l s) + | s `elem` prims + = return ls + | otherwise + = do env <- gets (typeAliases . rtEnv) + case M.lookup s env of + Nothing | isCon s -> do v <- lookupGhcVar $ Loc l s + let qs = symbol v + addSym (qs,v) + return $ Loc l qs + _ -> return ls + +isCon c + | Just (c,cs) <- T.uncons $ symbolText c = isUpper c + | otherwise = False + +instance Resolvable Symbol where + resolve l x = fmap val $ resolve l $ Loc l x + +instance Resolvable Sort where + resolve _ FInt = return FInt + resolve _ FNum = return FNum + resolve _ s@(FObj _) = return s --FObj . S <$> lookupName env m s + resolve _ s@(FVar _) = return s + resolve l (FFunc i ss) = FFunc i <$> resolve l ss + resolve _ (FApp tc ss) + | tcs' `elem` prims = FApp tc <$> ss' + | otherwise = FApp <$> (symbolFTycon.Loc l.symbol <$> lookupGhcTyCon tcs) <*> ss' + where + tcs@(Loc l tcs') = fTyconSymbol tc + ss' = resolve l ss + +instance Resolvable (UReft Reft) where + resolve l (U r p s) = U <$> resolve l r <*> resolve l p <*> return s + +instance Resolvable Reft where + resolve l (Reft (s, ras)) = Reft . (s,) <$> mapM resolveRefa ras + where + resolveRefa (RConc p) = RConc <$> resolve l p + resolveRefa kv = return kv + +instance Resolvable Predicate where + resolve l (Pr pvs) = Pr <$> resolve l pvs + +instance (Resolvable t) => Resolvable (PVar t) where + resolve l (PV n t v as) = PV n t v <$> mapM (third3M (resolve l)) as + +instance Resolvable () where + resolve l = return + +-------------------------------------------------------------------- +------ Predicate Types for WiredIns -------------------------------- +-------------------------------------------------------------------- + +maxArity :: Arity +maxArity = 7 + +wiredTyCons = fst wiredTyDataCons +wiredDataCons = snd wiredTyDataCons + +wiredTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, Located DataConP)]) +wiredTyDataCons = (concat tcs, mapSnd dummyLoc <$> concat dcs) + where + (tcs, dcs) = unzip l + l = [listTyDataCons] ++ map tupleTyDataCons [2..maxArity] + +listTyDataCons :: ([(TyCon, TyConP)] , [(DataCon, DataConP)]) +listTyDataCons = ( [(c, TyConP [(RTV tyv)] [p] [] [0] [] (Just fsize))] + , [(nilDataCon, DataConP l0 [(RTV tyv)] [p] [] [] [] lt) + , (consDataCon, DataConP l0 [(RTV tyv)] [p] [] [] cargs lt)]) + where + l0 = dummyPos "LH.Bare.listTyDataCons" + c = listTyCon + [tyv] = tyConTyVars c + t = rVar tyv :: RSort + fld = "fldList" + x = "xListSelector" + xs = "xsListSelector" + p = PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar fld)] + px = pdVarReft $ PV "p" (PVProp t) (vv Nothing) [(t, fld, EVar x)] + lt = rApp c [xt] [RPropP [] $ pdVarReft p] mempty + xt = rVar tyv + xst = rApp c [RVar (RTV tyv) px] [RPropP [] $ pdVarReft p] mempty + cargs = [(xs, xst), (x, xt)] + fsize = \x -> EApp (dummyLoc "len") [EVar x] + +tupleTyDataCons :: Int -> ([(TyCon, TyConP)] , [(DataCon, DataConP)]) +tupleTyDataCons n = ( [(c, TyConP (RTV <$> tyvs) ps [] [0..(n-2)] [] Nothing)] + , [(dc, DataConP l0 (RTV <$> tyvs) ps [] [] cargs lt)]) + where + l0 = dummyPos "LH.Bare.tupleTyDataCons" + c = tupleTyCon BoxedTuple n + dc = tupleCon BoxedTuple n + tyvs@(tv:tvs) = tyConTyVars c + (ta:ts) = (rVar <$> tyvs) :: [RSort] + flds = mks "fld_Tuple" + fld = "fld_Tuple" + x1:xs = mks ("x_Tuple" ++ show n) + ps = mkps pnames (ta:ts) ((fld, EVar fld):(zip flds (EVar <$>flds))) + ups = uPVar <$> ps + pxs = mkps pnames (ta:ts) ((fld, EVar x1):(zip flds (EVar <$> xs))) + lt = rApp c (rVar <$> tyvs) (RPropP [] . pdVarReft <$> ups) mempty + xts = zipWith (\v p -> RVar (RTV v) (pdVarReft p)) tvs pxs + cargs = reverse $ (x1, rVar tv) : (zip xs xts) + pnames = mks_ "p" + mks x = (\i -> symbol (x++ show i)) <$> [1..n] + mks_ x = (\i -> symbol (x++ show i)) <$> [2..n] + + +pdVarReft = (\p -> U mempty p mempty) . pdVar + +mkps ns (t:ts) ((f,x):fxs) = reverse $ mkps_ ns ts fxs [(t, f, x)] [] +mkps _ _ _ = error "Bare : mkps" + +mkps_ [] _ _ _ ps = ps +mkps_ (n:ns) (t:ts) ((f, x):xs) args ps = mkps_ ns ts xs (a:args) (p:ps) + where + p = PV n (PVProp t) (vv Nothing) args + a = (t, f, x) +mkps_ _ _ _ _ _ = error "Bare : mkps_" + +------------------------------------------------------------------------ +-- | Transforming Raw Strings using GHC Env ---------------------------- +------------------------------------------------------------------------ +ofBareType :: (PPrint r, Reftable r) => BRType r -> BareM (RRType r) +------------------------------------------------------------------------ +ofBareType (RVar a r) + = return $ RVar (symbolRTyVar a) r +ofBareType (RFun x t1 t2 _) + = liftM2 (rFun x) (ofBareType t1) (ofBareType t2) +ofBareType t@(RAppTy t1 t2 r) + = liftM3 RAppTy (ofBareType t1) (ofBareType t2) (return r) +ofBareType (RAllE x t1 t2) + = liftM2 (RAllE x) (ofBareType t1) (ofBareType t2) +ofBareType (REx x t1 t2) + = liftM2 (REx x) (ofBareType t1) (ofBareType t2) +ofBareType (RAllT a t) + = liftM (RAllT (symbolRTyVar a)) (ofBareType t) +ofBareType (RAllP π t) + = liftM2 RAllP (ofBPVar π) (ofBareType t) +ofBareType (RAllS s t) + = liftM (RAllS s) (ofBareType t) +ofBareType (RApp tc ts@[_] rs r) + | isList tc + = do tyi <- tcEnv <$> get + liftM2 (bareTCApp tyi r listTyCon) (mapM ofRef rs) (mapM ofBareType ts) +ofBareType (RApp tc ts rs r) + | isTuple tc + = do tyi <- tcEnv <$> get + liftM2 (bareTCApp tyi r c) (mapM ofRef rs) (mapM ofBareType ts) + where c = tupleTyCon BoxedTuple (length ts) +ofBareType (RApp tc ts rs r) + = do tyi <- tcEnv <$> get + liftM3 (bareTCApp tyi r) (lookupGhcTyCon tc) (mapM ofRef rs) (mapM ofBareType ts) +ofBareType (RCls c ts) + = liftM2 RCls (lookupGhcClass c) (mapM ofBareType ts) +ofBareType (ROth s) + = return $ ROth s +ofBareType (RHole r) + = return $ RHole r +ofBareType t + = errorstar $ "Bare : ofBareType cannot handle " ++ show t + +ofRef (RProp ss t) + = RProp <$> mapM ofSyms ss <*> ofBareType t +ofRef (RPropP ss r) + = (`RPropP` r) <$> mapM ofSyms ss +ofRef (RHProp _ _) + = errorstar "TODO:EFFECTS:ofRef" + + +ofSyms (x, t) + = liftM ((,) x) (ofBareType t) + +tyApp (RApp c ts rs r) ts' rs' r' = RApp c (ts ++ ts') (rs ++ rs') (r `meet` r') +tyApp t [] [] r = t `strengthen` r + +bareTCApp _ r c rs ts | Just (SynonymTyCon rhs) <- synTyConRhs_maybe c + = tyApp (subsTyVars_meet su $ ofType rhs) (drop nts ts) rs r + where tvs = tyConTyVars c + su = zipWith (\a t -> (rTyVar a, toRSort t, t)) tvs ts + nts = length tvs + +-- TODO expandTypeSynonyms here to +bareTCApp _ r c rs ts | isFamilyTyCon c && isTrivial t + = expandRTypeSynonyms $ t `strengthen` r + where t = rApp c ts rs mempty + +bareTCApp _ r c rs ts + = rApp c ts rs r + +expandRTypeSynonyms = ofType . expandTypeSynonyms . toType + +symbolRTyVar = rTyVar . stringTyVar . symbolString +-- stringTyVarTy = TyVarTy . stringTyVar + +mkMeasureDCon :: Ms.MSpec t LocSymbol -> BareM (Ms.MSpec t DataCon) +mkMeasureDCon m = (forM (measureCtors m) $ \n -> (val n,) <$> lookupGhcDataCon n) + >>= (return . mkMeasureDCon_ m) + +mkMeasureDCon_ :: Ms.MSpec t LocSymbol -> [(Symbol, DataCon)] -> Ms.MSpec t DataCon +mkMeasureDCon_ m ndcs = m' {Ms.ctorMap = cm'} + where + m' = fmap (tx.val) m + cm' = hashMapMapKeys (tx' . tx) $ Ms.ctorMap m' + tx = mlookup (M.fromList ndcs) + tx' = dataConSymbol + +measureCtors :: Ms.MSpec t LocSymbol -> [LocSymbol] +measureCtors = sortNub . fmap ctor . concat . M.elems . Ms.ctorMap + +-- mkMeasureSort :: (PVarable pv, Reftable r) => Ms.MSpec (BRType pv r) bndr-> BareM (Ms.MSpec (RRType pv r) bndr) +mkMeasureSort (Ms.MSpec c mm cm im) + = Ms.MSpec c <$> forM mm tx <*> forM cm tx <*> forM im tx + where + tx m = liftM (\s' -> m {sort = s'}) (ofBareType (sort m)) + + + +----------------------------------------------------------------------- +-- | LH Primitive TyCons ---------------------------------------------- +----------------------------------------------------------------------- + +propTyCon, hpropTyCon :: TyCon +propTyCon = symbolTyCon 'w' 24 propConName +hpropTyCon = symbolTyCon 'w' 24 hpropConName + +----------------------------------------------------------------------- +---------------- Bare Predicate: DataCon Definitions ------------------ +----------------------------------------------------------------------- + +makeConTypes (name,spec) = inModule name $ makeConTypes' $ Ms.dataDecls spec + +makeConTypes' :: [DataDecl] -> BareM ([(TyCon, TyConP)], [[(DataCon, Located DataConP)]]) +makeConTypes' dcs = unzip <$> mapM ofBDataDecl dcs + +ofBDataDecl :: DataDecl -> BareM ((TyCon, TyConP), [(DataCon, Located DataConP)]) +ofBDataDecl (D tc as ps ls cts pos sfun) + = do πs <- mapM ofBPVar ps + tc' <- lookupGhcTyCon tc + cts' <- mapM (ofBDataCon lc tc' αs ps ls πs) cts + let tys = [t | (_, dcp) <- cts', (_, t) <- tyArgs dcp] + let initmap = zip (uPVar <$> πs) [0..] + let varInfo = concatMap (getPsSig initmap True) tys + let neutral = [0 .. (length πs)] L.\\ (fst <$> varInfo) + let cov = neutral ++ [i | (i, b)<- varInfo, b, i >=0] + let contr = neutral ++ [i | (i, b)<- varInfo, not b, i >=0] + return ((tc', TyConP αs πs ls cov contr sfun), (mapSnd (Loc lc) <$> cts')) + where + αs = RTV . symbolTyVar <$> as + lc = loc tc + +getPsSig m pos (RAllT _ t) + = getPsSig m pos t +getPsSig m pos (RApp _ ts rs r) + = addps m pos r ++ concatMap (getPsSig m pos) ts + ++ concatMap (getPsSigPs m pos) rs +getPsSig m pos (RVar _ r) + = addps m pos r +getPsSig m pos (RAppTy t1 t2 r) + = addps m pos r ++ getPsSig m pos t1 ++ getPsSig m pos t2 +getPsSig m pos (RFun _ t1 t2 r) + = addps m pos r ++ getPsSig m pos t2 ++ getPsSig m (not pos) t1 + + +getPsSigPs m pos (RPropP _ r) = addps m pos r +getPsSigPs m pos (RProp _ t) = getPsSig m pos t +getPsSigPs _ _ (RHProp _ _) = errorstar "TODO:EFFECTS:getPsSigPs" + +addps m pos (U _ ps _) = (flip (,)) pos . f <$> pvars ps + where f = fromMaybe (error "Bare.addPs: notfound") . (`L.lookup` m) . uPVar +-- ofBPreds = fmap (fmap stringTyVarTy) +dataDeclTyConP d + = do let αs = fmap (RTV . symbolTyVar) (tycTyVars d) -- as + πs <- mapM ofBPVar (tycPVars d) -- ps + tc' <- lookupGhcTyCon (tycName d) -- tc + return $ (tc', TyConP αs πs) + +-- ofBPreds = fmap (fmap stringTyVarTy) +ofBPVar :: PVar BSort -> BareM (PVar RSort) +ofBPVar = mapM_pvar ofBareType + +mapM_pvar :: (Monad m) => (a -> m b) -> PVar a -> m (PVar b) +mapM_pvar f (PV x t v txys) + = do t' <- forM t f + txys' <- mapM (\(t, x, y) -> liftM (, x, y) (f t)) txys + return $ PV x t' v txys' + +-- TODO:EFFECTS:ofBDataCon +ofBDataCon l tc αs ps ls πs (c, xts) + = do c' <- lookupGhcDataCon c + ts' <- mapM (mkSpecType' l ps) ts + let cs = map ofType (dataConStupidTheta c') + let t0 = rApp tc rs (RPropP [] . pdVarReft <$> πs) mempty + return $ (c', DataConP l αs πs ls cs (reverse (zip xs ts')) t0) + where + (xs, ts) = unzip xts + rs = [rVar α | RTV α <- αs] + +----------------------------------------------------------------------- +---------------- Bare Predicate: RefTypes ----------------------------- +----------------------------------------------------------------------- + +txParams f πs t = mapReft (f (txPvar (predMap πs t))) t + +txPvar :: M.HashMap Symbol UsedPVar -> UsedPVar -> UsedPVar +txPvar m π = π { pargs = args' } + where args' | not (null (pargs π)) = zipWith (\(_,x ,_) (t,_,y) -> (t, x, y)) (pargs π') (pargs π) + | otherwise = pargs π' + π' = fromMaybe (errorstar err) $ M.lookup (pname π) m + err = "Bare.replaceParams Unbound Predicate Variable: " ++ show π + +predMap πs t = {-Ex.assert (M.size xπm == length xπs)-} xπm + where xπm = M.fromList xπs + xπs = [(pname π, π) | π <- πs ++ rtypePredBinds t] + +rtypePredBinds = map uPVar . ty_preds . toRTypeRep + +-- rtypePredBinds t = everything (++) ([] `mkQ` grab) t +-- where grab ((RAllP pv _) :: BRType RPVar RPredicate) = [pv] +-- grab _ = [] + +---------------------------------------------------------------------------------------------- +----- Checking GhcSpec ----------------------------------------------------------------------- +---------------------------------------------------------------------------------------------- + +checkGhcSpec :: [(ModName, Ms.BareSpec)] + -> GhcSpec -> Either [Error] GhcSpec + +checkGhcSpec specs sp = applyNonNull (Right sp) Left errors + where + errors = mapMaybe (checkBind "constructor" emb tcEnv env) (dcons sp) + ++ mapMaybe (checkBind "measure" emb tcEnv env) (measSpec sp) + ++ mapMaybe (checkInv emb tcEnv env) (invariants sp) + ++ (checkIAl emb tcEnv env) (ialiases sp) + ++ checkMeasures emb env ms + ++ mapMaybe checkMismatch sigs + ++ checkDuplicate (tySigs sp) + ++ checkDuplicate (asmSigs sp) + ++ checkDupIntersect (tySigs sp) (asmSigs sp) + ++ checkRTAliases "Type Alias" env tAliases + ++ checkRTAliases "Pred Alias" env pAliases + -- ++ checkDuplicateRTAlias "Predicate Alias" pAliases + -- ++ checkRTAliasSyms "Predicate Alias" (concat [Ms.paliases sp | (_, sp) <- specs]) + + + tAliases = concat [Ms.aliases sp | (_, sp) <- specs] + pAliases = concat [Ms.paliases sp | (_, sp) <- specs] + dcons spec = [ (v, Loc l dc) | (v, dc) <- dataConSpec (dconsP spec), let l = getSourcePos v ] + emb = tcEmbeds sp + env = ghcSpecEnv sp + tcEnv = tyconEnv sp + ms = measures sp + measSpec sp = [(x, uRType <$> t) | (x, t) <- meas sp] + sigs = tySigs sp ++ asmSigs sp + + +type ReplaceM = ReaderT ( M.HashMap Symbol Symbol + , SEnv SortedReft + , TCEmb TyCon + , M.HashMap TyCon RTyCon + ) (State ( M.HashMap Var (Located SpecType) + , M.HashMap Var [Expr] + )) + +replaceLocalBinds :: TCEmb TyCon + -> M.HashMap TyCon RTyCon + -> [(Var, Located SpecType)] + -> [(Var, [Expr])] + -> SEnv SortedReft + -> CoreProgram + -> ([(Var, Located SpecType)], [(Var, [Expr])]) +replaceLocalBinds emb tyi sigs texprs senv cbs + = (M.toList s, M.toList t) + where + (s,t) = execState (runReaderT (mapM_ (`traverseBinds` return ()) cbs) + (M.empty, senv, emb, tyi)) + (M.fromList sigs, M.fromList texprs) + +traverseExprs (Let b e) + = traverseBinds b (traverseExprs e) +traverseExprs (Lam _ e) + = traverseExprs e +traverseExprs (App x y) + = traverseExprs x >> traverseExprs y +traverseExprs (Case e _ _ as) + = traverseExprs e >> mapM_ (traverseExprs . thd3) as +traverseExprs (Cast e _) + = traverseExprs e +traverseExprs (Tick _ e) + = traverseExprs e +traverseExprs _ + = return () + +traverseBinds b k + = do (env', fenv', emb, tyi) <- ask + let env = L.foldl' (\m v -> M.insert (takeWhileSym (/='#') $ symbol v) (symbol v) m) env' vs + fenv = L.foldl' (\m v -> insertSEnv (symbol v) (rTypeSortedReft emb (ofType $ varType v :: RSort)) m) fenv' vs + withReaderT (const (env,fenv,emb,tyi)) $ do + mapM_ replaceLocalBindsOne vs + mapM_ traverseExprs es + k + where + vs = bindersOf b + es = rhssOfBind b + +replaceLocalBindsOne :: Var -> ReplaceM () +replaceLocalBindsOne v + = do mt <- gets (M.lookup v . fst) + case mt of + Nothing -> return () + Just (Loc l (toRTypeRep -> t@(RTypeRep {..}))) -> do + (env',fenv,emb,tyi) <- ask + let f m k = M.lookupDefault k k m + let (env,args) = L.mapAccumL (\e (v,t) -> (M.insert v v e, substa (f e) t)) + env' (zip ty_binds ty_args) + let res = substa (f env) ty_res + let t' = fromRTypeRep $ t { ty_args = args, ty_res = res } + let msg = ErrTySpec (sourcePosSrcSpan l) (pprint v) t' + case checkTy msg emb tyi fenv t' of + Just err -> Ex.throw err + Nothing -> modify (first $ M.insert v (Loc l t')) + mes <- gets (M.lookup v . snd) + case mes of + Nothing -> return () + Just es -> do + let es' = substa (f env) es + case checkExpr "termination" emb fenv (v, Loc l t', es') of + Just err -> Ex.throw err + Nothing -> modify (second $ M.insert v es') + + + +checkInv :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> Located SpecType -> Maybe Error +checkInv emb tcEnv env t = checkTy err emb tcEnv env (val t) + where + err = ErrInvt (sourcePosSrcSpan $ loc t) (val t) + +checkIAl :: TCEmb TyCon -> TCEnv -> SEnv SortedReft -> [(Located SpecType, Located SpecType)] -> [Error] +checkIAl emb tcEnv env ials = catMaybes $ concatMap (checkIAlOne emb tcEnv env) ials + +checkIAlOne emb tcEnv env (t1, t2) = checkEq : (tcheck <$> [t1, t2]) + where + tcheck t = checkTy (err t) emb tcEnv env (val t) + err t = ErrIAl (sourcePosSrcSpan $ loc t) (val t) + t1' :: RSort + t1' = toRSort $ val t1 + t2' :: RSort + t2' = toRSort $ val t2 + checkEq = if (t1' == t2') then Nothing else Just errmis + errmis = ErrIAlMis (sourcePosSrcSpan $ loc t1) (val t1) (val t2) emsg + emsg = pprint t1 <+> text "does not match with" <+> pprint t2 + + +checkRTAliases msg env as = err1s -- ++ err2s + where + err1s = checkDuplicateRTAlias msg as + err2s = concatMap (checkRTAliasWF env) as + +checkRTAliasWF env a = {- trace ("checkRTAliasWF: " ++ rtName a) $ -} + mkErr <$> filter (not . ok) aSyms + where + aSyms = {- traceShow ("RTAWF: " ++ aName) $ -} syms $ rtBody a + ok x = memberSEnv x env || x `elem` params + params = symbol <$> rtVArgs a + mkErr = ErrUnbound sp . pprint + sp = sourcePosSrcSpan (rtPos a) + aName = rtName a + + +checkBind :: (PPrint v) => String -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> (v, Located SpecType) -> Maybe Error +checkBind s emb tcEnv env (v, Loc l t) = checkTy msg emb tcEnv env' t + where + msg = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t + env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms + +checkExpr :: (Eq v, PPrint v) => String -> TCEmb TyCon -> SEnv SortedReft -> (v, Located SpecType, [Expr])-> Maybe Error +checkExpr s emb env (v, Loc l t, es) = mkErr <$> go es + where + mkErr = ErrTySpec (sourcePosSrcSpan l) (text s <+> pprint v) t + go = foldl (\err e -> err <|> checkSorted env' e) Nothing + env' = foldl (\e (x, s) -> insertSEnv x s e) env'' wiredSortedSyms + env'' = mapSEnv sr_sort $ foldl (\e (x,s) -> insertSEnv x s e) env xss + xss = mapSnd rSort <$> (uncurry zip $ dropThd3 $ bkArrowDeep t) + rSort = rTypeSortedReft emb + msg = "Bare.checkExpr " ++ showpp v ++ " not found\n" + ++ "\t Try give a haskell type signature to the recursive function" + +checkTy :: (Doc -> Error) -> TCEmb TyCon -> TCEnv -> SEnv SortedReft -> SpecType -> Maybe Error +checkTy mkE emb tcEnv env t = mkE <$> checkRType emb env (txRefSort tcEnv emb t) + +checkDupIntersect :: [(Var, Located SpecType)] -> [(Var, Located SpecType)] -> [Error] +checkDupIntersect xts mxts = concatMap mkWrn dups + where + mkWrn (x, t) = pprWrn x (sourcePosSrcSpan $ loc t) + dups = L.intersectBy (\x y -> (fst x == fst y)) mxts xts + pprWrn v l = trace ("WARNING: Assume Overwrites Specifications for "++ show v ++ " : " ++ showPpr l) [] + +checkDuplicate :: [(Var, Located SpecType)] -> [Error] +checkDuplicate xts = mkErr <$> dups + where + mkErr (x, ts) = ErrDupSpecs (getSrcSpan x) (pprint x) (sourcePosSrcSpan . loc <$> ts) + dups = [z | z@(x, t1:t2:_) <- M.toList $ group xts ] + +checkDuplicateRTAlias :: String -> [RTAlias s a] -> [Error] +checkDuplicateRTAlias s tas = mkErr <$> dups + where + mkErr xs@(x:_) = ErrDupAlias (sourcePosSrcSpan $ rtPos x) + (text s) + (pprint $ rtName x) + (sourcePosSrcSpan . rtPos <$> xs) + dups = [z | z@(_:_:_) <- L.groupBy (\x y -> rtName x == rtName y) tas] + + + +checkMismatch :: (Var, Located SpecType) -> Maybe Error +checkMismatch (x, t) = if ok then Nothing else Just err + where + ok = tyCompat x (val t) + err = errTypeMismatch x t + +tyCompat x t = lhs == rhs + where + lhs :: RSort = toRSort t + rhs :: RSort = ofType $ varType x + msg = printf "tyCompat: l = %s r = %s" (showpp lhs) (showpp rhs) + +ghcSpecEnv sp = fromListSEnv binds + where + emb = tcEmbeds sp + binds = [(x, rSort t) | (x, Loc _ t) <- meas sp] + ++ [(symbol v, rSort t) | (v, Loc _ t) <- ctors sp] + ++ [(x, vSort v) | (x, v) <- freeSyms sp, isConLikeId v] + rSort = rTypeSortedReft emb + vSort = rSort . varRSort + varRSort :: Var -> RSort + varRSort = ofType . varType + +errTypeMismatch :: Var -> Located SpecType -> Error +errTypeMismatch x t = ErrMismatch (sourcePosSrcSpan $ loc t) (pprint x) (varType x) (val t) + +------------------------------------------------------------------------------------------------ +-- | @checkRType@ determines if a type is malformed in a given environment --------------------- +------------------------------------------------------------------------------------------------ +checkRType :: (PPrint r, Reftable r) => TCEmb TyCon -> SEnv SortedReft -> RRType r -> Maybe Doc +------------------------------------------------------------------------------------------------ + +checkRType emb env t = efoldReft cb (rTypeSortedReft emb) f insertPEnv env Nothing t + where + cb c ts = classBinds (RCls c ts) + f env me r err = err <|> checkReft env emb me r + insertPEnv p γ = insertsSEnv γ (mapSnd (rTypeSortedReft emb) <$> pbinds p) + pbinds p = (pname p, pvarRType p :: RSort) + : [(x, t) | (t, x, _) <- pargs p] + + +checkReft :: (PPrint r, Reftable r) => SEnv SortedReft -> TCEmb TyCon -> Maybe (RRType r) -> r -> Maybe Doc +checkReft env emb Nothing _ = Nothing -- TODO:RPropP/Ref case, not sure how to check these yet. +checkReft env emb (Just t) _ = (dr $+$) <$> checkSortedReftFull env' r + where + r = rTypeSortedReft emb t + dr = text "Sort Error in Refinement:" <+> pprint r + env' = foldl (\e (x, s) -> insertSEnv x (RR s mempty) e) env wiredSortedSyms + +-- DONT DELETE the below till we've added pred-checking as well +-- checkReft env emb (Just t) _ = checkSortedReft env xs (rTypeSortedReft emb t) +-- where xs = fromMaybe [] $ params <$> stripRTypeBase t + +-- checkSig env (x, t) +-- = case filter (not . (`S.member` env)) (freeSymbols t) of +-- [] -> True +-- ys -> errorstar (msg ys) +-- where +-- msg ys = printf "Unkown free symbols: %s in specification for %s \n%s\n" (showpp ys) (showpp x) (showpp t) + +--------------------------------------------------------------------------------------------------- +-- | @checkMeasures@ determines if a measure definition is wellformed ----------------------------- +--------------------------------------------------------------------------------------------------- +checkMeasures :: M.HashMap TyCon FTycon -> SEnv SortedReft -> [Measure SpecType DataCon] -> [Error] +--------------------------------------------------------------------------------------------------- +checkMeasures emb env = concatMap (checkMeasure emb env) + +checkMeasure :: M.HashMap TyCon FTycon -> SEnv SortedReft -> Measure SpecType DataCon -> [Error] +checkMeasure emb γ (M name@(Loc src n) sort body) + = [txerror e | Just e <- checkMBody γ emb name sort <$> body] + where + txerror = ErrMeas (sourcePosSrcSpan src) n + +checkMBody γ emb name sort (Def s c bs body) = checkMBody' emb sort γ' body + where + γ' = L.foldl' (\γ (x, t) -> insertSEnv x t γ) γ xts + xts = zip bs $ rTypeSortedReft emb . subsTyVars_meet su <$> ty_args trep + trep = toRTypeRep ct + su = checkMBodyUnify (ty_res trep) (head $ snd3 $ bkArrowDeep sort) + ct = ofType $ dataConUserType c :: SpecType + +checkMBodyUnify = go + where + go (RVar tv _) t = [(tv, toRSort t, t)] + go t@(RApp {}) t'@(RApp {}) = concat $ zipWith go (rt_args t) (rt_args t') + go _ _ = [] + +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 + where + 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' } + trep' = toRTypeRep sort + + + +------------------------------------------------------------------------------- +-- | Replace Predicate Arguments With Existentials ---------------------------- +------------------------------------------------------------------------------- + +data ExSt = ExSt { fresh :: Int + , emap :: M.HashMap Symbol (RSort, Expr) + , pmap :: M.HashMap Symbol RPVar + } + +-- | Niki: please write more documentation for this, maybe an example? +-- I can't really tell whats going on... (RJ) + +txExpToBind :: SpecType -> SpecType +txExpToBind t = evalState (expToBindT t) (ExSt 0 M.empty πs) + where πs = M.fromList [(pname p, p) | p <- ty_preds $ toRTypeRep t ] + +expToBindT :: SpecType -> State ExSt SpecType +expToBindT (RVar v r) + = expToBindRef r >>= addExists . RVar v +expToBindT (RFun x t1 t2 r) + = do t1' <- expToBindT t1 + t2' <- expToBindT t2 + expToBindRef r >>= addExists . RFun x t1' t2' +expToBindT (RAllT a t) + = liftM (RAllT a) (expToBindT t) +expToBindT (RAllP p t) + = liftM (RAllP p) (expToBindT t) +expToBindT (RAllS s t) + = liftM (RAllS s) (expToBindT t) +expToBindT (RApp c ts rs r) + = do ts' <- mapM expToBindT ts + rs' <- mapM expToBindReft rs + expToBindRef r >>= addExists . RApp c ts' rs' +expToBindT (RCls c ts) + = liftM (RCls c) (mapM expToBindT ts) +expToBindT (RAppTy t1 t2 r) + = do t1' <- expToBindT t1 + t2' <- expToBindT t2 + expToBindRef r >>= addExists . RAppTy t1' t2' +expToBindT t + = return t + +expToBindReft :: SpecProp -> State ExSt SpecProp +expToBindReft (RProp s t) = RProp s <$> expToBindT t +expToBindReft (RPropP s r) = RPropP s <$> expToBindRef r +expToBindReft (RHProp _ _) = errorstar "TODO:EFFECTS:expToBindReft" + +getBinds :: State ExSt (M.HashMap Symbol (RSort, Expr)) +getBinds + = do bds <- emap <$> get + modify $ \st -> st{emap = M.empty} + return bds + +addExists t = liftM (M.foldlWithKey' addExist t) getBinds + +addExist t x (tx, e) = RAllE x t' t + where t' = (ofRSort tx) `strengthen` uTop r + r = Reft (vv Nothing, [RConc (PAtom Eq (EVar (vv Nothing)) e)]) + +expToBindRef :: UReft r -> State ExSt (UReft r) +expToBindRef (U r (Pr p) l) + = mapM expToBind p >>= return . (\p -> U r p l). Pr + +expToBind :: UsedPVar -> State ExSt UsedPVar +expToBind p + = do Just π <- liftM (M.lookup (pname p)) (pmap <$> get) + let pargs0 = zip (pargs p) (fst3 <$> pargs π) + pargs' <- mapM expToBindParg pargs0 + return $ p{pargs = pargs'} + +expToBindParg :: (((), Symbol, Expr), RSort) -> State ExSt ((), Symbol, Expr) +expToBindParg ((t, s, e), s') = liftM ((,,) t s) (expToBindExpr e s') + +expToBindExpr :: Expr -> RSort -> State ExSt Expr +expToBindExpr e@(EVar s) _ | isLower $ headSym $ symbol s + = return e +expToBindExpr e t + = do s <- freshSymbol + modify $ \st -> st{emap = M.insert s (t, e) (emap st)} + return $ EVar s + +freshSymbol :: State ExSt Symbol +freshSymbol + = do n <- fresh <$> get + modify $ \s -> s{fresh = n+1} + return $ symbol $ "ex#" ++ show n + +maybeTrue :: NamedThing a => a -> ModName -> NameSet -> RReft -> RReft +maybeTrue x target exports r + | isInternalName name || inTarget && notExported + = r + | otherwise + = killHoles r + where + inTarget = moduleName (nameModule name) == getModName target + name = getName x + notExported = not $ getName x `elemNameSet` exports + killHoles r@(U (Reft (v,rs)) _ _) = r { ur_reft = Reft (v, filter (not . isHole) rs) } + +------------------------------------------------------------------------------------- +-- | Tasteful Error Messages -------------------------------------------------------- +------------------------------------------------------------------------------------- + +berrUnknownVar = berrUnknown "Variable" + +berrUnknown :: (PPrint a) => String -> Located a -> String +berrUnknown thing x = printf "[%s]\nSpecification for unknown %s : %s" + thing (showpp $ loc x) (showpp $ val x) diff --git a/src/Language/Haskell/Liquid/CTags.hs b/src/Language/Haskell/Liquid/CTags.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/CTags.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE TupleSections #-} +-- | This module contains the code for generating "tags" for constraints +-- based on their source, i.e. the top-level binders under which the +-- constraint was generated. These tags are used by fixpoint to +-- prioritize constraints by the "source-level" function. + +module Language.Haskell.Liquid.CTags ( + -- * Type for constraint tags + TagKey, TagEnv + + -- * Default tag value + , defaultTag + + -- * Constructing @TagEnv@ + , makeTagEnv + + -- * Accessing @TagEnv@ + , getTag, memTagEnv + +) where + +import Var +import CoreSyn + +-- import qualified Data.List as L +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import qualified Data.Graph as G + +import Language.Fixpoint.Misc (mapSnd, traceShow) +import Language.Fixpoint.Types (Tag) +import Language.Haskell.Liquid.GhcInterface (freeVars) + +-- | The @TagKey@ is the top-level binder, and @Tag@ is a singleton Int list + +type TagKey = Var +type TagEnv = M.HashMap TagKey Tag + +-- TODO: use the "callgraph" SCC to do this numbering. + +defaultTag :: Tag +defaultTag = [0] + +memTagEnv :: TagKey -> TagEnv -> Bool +memTagEnv = M.member + +makeTagEnv :: [CoreBind] -> TagEnv +makeTagEnv = M.map (:[]) . callGraphRanks . makeCallGraph + +-- makeTagEnv = M.fromList . (`zip` (map (:[]) [1..])). L.sort . map fst . concatMap bindEqns + +getTag :: TagKey -> TagEnv -> Tag +getTag = M.lookupDefault defaultTag + +------------------------------------------------------------------------------------------------------ + +type CallGraph = [(Var, [Var])] -- caller-callee pairs + +callGraphRanks :: CallGraph -> M.HashMap Var Int +-- callGraphRanks cg = traceShow ("CallGraph Ranks: " ++ show cg) $ callGraphRanks' cg + +callGraphRanks = M.fromList . concat . index . mkScc + where mkScc cg = G.stronglyConnComp [(u, u, vs) | (u, vs) <- cg] + index = zipWith (\i -> map (, i) . G.flattenSCC) [1..] + +makeCallGraph :: [CoreBind] -> CallGraph +makeCallGraph cbs = mapSnd calls `fmap` xes + where xes = concatMap bindEqns cbs + xs = S.fromList $ map fst xes + calls = filter (`S.member` xs) . freeVars S.empty + +bindEqns (NonRec x e) = [(x, e)] +bindEqns (Rec xes) = xes + + diff --git a/src/Language/Haskell/Liquid/CmdLine.hs b/src/Language/Haskell/Liquid/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/CmdLine.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-cse #-} + +-- | 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 +-- here. The idea should be to report the error, the source position that +-- causes it, generate a suitable .json file and then exit. + + +module Language.Haskell.Liquid.CmdLine ( + -- * Get Command Line Configuration + getOpts, mkOpts + + -- * Update Configuration With Pragma + , withPragmas + + -- * Exit Function + , exitWithResult + + -- * Diff check mode + , diffcheck +) where + +import Control.DeepSeq +import Control.Monad +import Control.Applicative ((<$>)) + +import Data.List (foldl', nub) +import Data.Maybe +import Data.Monoid +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import System.Directory (getCurrentDirectory) +import System.FilePath (dropFileName) +import System.Environment (lookupEnv, withArgs) +import System.Console.CmdArgs hiding (Loud) +import System.Console.CmdArgs.Verbosity (whenLoud) + +import Language.Fixpoint.Misc +import Language.Fixpoint.Files +import Language.Fixpoint.Names (dropModuleNames) +import Language.Fixpoint.Types hiding (config) +import Language.Fixpoint.Config hiding (config, Config, real) +import Language.Haskell.Liquid.Annotate +import Language.Haskell.Liquid.Misc +import Language.Haskell.Liquid.PrettyPrint +import Language.Haskell.Liquid.Types hiding (config, typ, name) + +import Name +import SrcLoc (SrcSpan) +import Text.PrettyPrint.HughesPJ +import Text.Parsec.Pos (newPos) + + +--------------------------------------------------------------------------------- +-- Parsing Command Line---------------------------------------------------------- +--------------------------------------------------------------------------------- + +config = cmdArgsMode $ Config { + files + = def &= typ "TARGET" + &= args + &= typFile + + , idirs + = def &= typDir + &= help "Paths to Spec Include Directory " + + , fullcheck + = def + &= help "Full Checking: check all binders (DEFAULT)" + + , diffcheck + = def + &= help "Incremental Checking: only check changed binders" + + , real + = def + &= help "Supports real number arithmetic" + + , binders + = def &= help "Check a specific set of binders" + + , noPrune + = def &= help "Disable prunning unsorted Predicates" + &= name "no-prune-unsorted" + + , notermination + = def &= help "Disable Termination Check" + &= name "no-termination-check" + + , nocaseexpand + = def &= help "Disable Termination Check" + &= name "no-case-expand" + , strata + = def &= help "Enable Strata Analysis" + + , notruetypes + = def &= help "Disable Trueing Top Level Types" + &= name "no-true-types" + + , totality + = def &= help "Check totality" + + , smtsolver + = def &= help "Name of SMT-Solver" + + , noCheckUnknown + = def &= explicit + &= name "no-check-unknown" + &= help "Don't complain about specifications for unexported and unused values " + + , maxParams + = 2 &= help "Restrict qualifier mining to those taking at most `m' parameters (2 by default)" + + , shortNames + = def &= name "short-names" + &= help "Print shortened names, i.e. drop all module qualifiers." + + , shortErrors + = def &= name "short-errors" + &= help "Don't show long error messages, just line numbers." + + , ghcOptions + = def &= name "ghc-option" + &= typ "OPTION" + &= help "Pass this option to GHC" + + , cFiles + = def &= name "c-files" + &= typ "OPTION" + &= help "Tell GHC to compile and link against these files" + + -- , verbose + -- = def &= help "Generate Verbose Output" + -- &= name "verbose-output" + + } &= verbosity + &= program "liquid" + &= help "Refinement Types for Haskell" + &= summary copyright + &= details [ "LiquidHaskell is a Refinement Type based verifier for Haskell" + , "" + , "To check a Haskell file foo.hs, type:" + , " liquid foo.hs " + ] + +getOpts :: IO Config +getOpts = do cfg0 <- envCfg + cfg1 <- mkOpts =<< cmdArgsRun config + pwd <- getCurrentDirectory + cfg <- canonicalizePaths (fixCfg $ mconcat [cfg0, cfg1]) pwd + whenNormal $ putStrLn copyright + return cfg + +fixCfg cfg = cfg { diffcheck = diffcheck cfg && not (fullcheck cfg) } + +envCfg = do so <- lookupEnv "LIQUIDHASKELL_OPTS" + case so of + Nothing -> return mempty + Just s -> parsePragma $ envLoc s + where + envLoc = Loc (newPos "ENVIRONMENT" 0 0) + +copyright = "LiquidHaskell © Copyright 2009-14 Regents of the University of California. All Rights Reserved.\n" + +mkOpts :: Config -> IO Config +mkOpts cfg + = do files' <- sortNub . concat <$> mapM getHsTargets (files cfg) + -- idirs' <- if null (idirs cfg) then single <$> getIncludeDir else return (idirs cfg) + id0 <- getIncludeDir + return $ cfg { files = files' } + { idirs = (dropFileName <$> files') ++ [id0] ++ idirs cfg } + -- tests fail if you flip order of idirs' + +--------------------------------------------------------------------------------------- +-- | Updating options +--------------------------------------------------------------------------------------- + +--------------------------------------------------------------------------------------- +withPragmas :: Config -> FilePath -> [Located String] -> IO Config +--------------------------------------------------------------------------------------- +withPragmas cfg fp ps + = foldM withPragma cfg ps >>= flip canonicalizePaths fp + +withPragma :: Config -> Located String -> IO Config +withPragma c s = (c `mappend`) <$> parsePragma s + +parsePragma :: Located String -> IO Config +parsePragma s = withArgs [val s] $ cmdArgsRun config + +--------------------------------------------------------------------------------------- +-- | Monoid instances for updating options +--------------------------------------------------------------------------------------- + + +instance Monoid Config where + mempty = Config def def def def def def def def def def def def def 2 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 + , real = real c1 || real c2 + , diffcheck = diffcheck c1 || diffcheck c2 + , binders = sortNub $ binders c1 ++ binders c2 + , noCheckUnknown = noCheckUnknown c1 || noCheckUnknown c2 + , notermination = notermination c1 || notermination c2 + , nocaseexpand = nocaseexpand c1 || nocaseexpand c2 + , strata = strata c1 || strata c2 + , notruetypes = notruetypes c1 || notruetypes c2 + , totality = totality c1 || totality c2 + , noPrune = noPrune c1 || noPrune c2 + , maxParams = maxParams c1 `max` maxParams c2 + , smtsolver = smtsolver c1 `mappend` smtsolver c2 + , shortNames = shortNames c1 || shortNames c2 + , shortErrors = shortErrors c1 || shortErrors c2 + , ghcOptions = ghcOptions c1 ++ ghcOptions c2 + , cFiles = cFiles c1 ++ cFiles c2 + } + +instance Monoid SMTSolver where + mempty = def + mappend s1 s2 + | s1 == s2 = s1 + | s2 == def = s1 + | otherwise = s2 + + +------------------------------------------------------------------------ +-- | Exit Function ----------------------------------------------------- +------------------------------------------------------------------------ + +------------------------------------------------------------------------ +exitWithResult :: Config -> FilePath -> Output Doc -> IO (Output Doc) +------------------------------------------------------------------------ +exitWithResult cfg target out + = do let r = o_result out + let rs = showFix r + {-# SCC "annotate" #-} annotate cfg target out + donePhase Loud "annotate" + writeCheckVars $ o_vars out + writeWarns $ o_warns out + writeResult cfg (colorResult r) r + writeFile (extFileName Result target) rs + return $ out { o_result = if null (o_warns out) then r else Unsafe [] } + +writeWarns [] = return () +writeWarns ws = colorPhaseLn Angry "Warnings:" "" >> putStrLn (unlines $ nub ws) + +writeCheckVars Nothing = return () +writeCheckVars (Just []) = colorPhaseLn Loud "Checked Binders: None" "" +writeCheckVars (Just ns) = colorPhaseLn Loud "Checked Binders:" "" >> forM_ ns (putStrLn . symbolString . dropModuleNames . symbol) + +writeResult cfg c = mapM_ (writeDoc c) . zip [0..] . resDocs tidy + where + tidy = if shortErrors cfg then Lossy else Full + writeDoc c (i, d) = writeBlock c i $ lines $ render d + writeBlock c _ [] = return () + writeBlock c 0 ss = forM_ ss (colorPhaseLn c "") + writeBlock c _ ss = forM_ ("\n" : ss) putStrLn + +resDocs _ Safe = [text "SAFE"] +resDocs k (Crash xs s) = text ("CRASH: " ++ s) : pprManyOrdered k "" xs +resDocs k (Unsafe xs) = text "UNSAFE" : pprManyOrdered k "" (nub xs) +resDocs _ (UnknownError d) = [text $ "PANIC: Unexpected Error: " ++ d, reportUrl] + +reportUrl = text "Please submit a bug report at: https://github.com/ucsd-progsys/liquidhaskell" + + +instance Fixpoint (FixResult Error) where + toFix = vcat . resDocs Full + diff --git a/src/Language/Haskell/Liquid/Constraint.hs b/src/Language/Haskell/Liquid/Constraint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Constraint.hs @@ -0,0 +1,1941 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module defines the representation of Subtyping and WF Constraints, and +-- the code for syntax-directed constraint generation. + +module Language.Haskell.Liquid.Constraint ( + + -- * Constraint information output by generator + CGInfo (..) + + -- * Function that does the actual generation + , generateConstraints + + -- * Project Constraints to Fixpoint Format + , cgInfoFInfo , cgInfoFInfoBot, cgInfoFInfoKvars + + -- * KVars in constraints, for debug/profile purposes + -- , kvars, kvars' + ) where + +import CoreSyn +import SrcLoc +import Type -- (coreEqType) +import PrelNames +import qualified TyCon as TC +import qualified DataCon as DC + +import TypeRep +import Class (Class, className) +import Var +import Id +import Name +import NameSet +import Text.PrettyPrint.HughesPJ hiding (first) + +import Control.Monad.State + +import Control.Applicative ((<$>)) +import Control.Exception.Base + +import Data.Monoid (mconcat, mempty, mappend) +import Data.Maybe (fromJust, isJust, fromMaybe, catMaybes) +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import qualified Data.Text as T +import Data.Bifunctor +import Data.List (foldl') + +import Text.Printf + +import qualified Language.Haskell.Liquid.CTags as Tg +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Names (dropModuleNames) +import Language.Fixpoint.Sort (pruneUnsortedReft) + +import Language.Haskell.Liquid.Fresh + +import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, freeTyVars, Def) +import Language.Haskell.Liquid.Bare +import Language.Haskell.Liquid.Strata +import Language.Haskell.Liquid.Annotate +import Language.Haskell.Liquid.GhcInterface +import Language.Haskell.Liquid.RefType +import Language.Haskell.Liquid.PredType hiding (freeTyVars) +import Language.Haskell.Liquid.PrettyPrint +import Language.Haskell.Liquid.GhcMisc (isInternal, collectArguments, getSourcePos, pprDoc, tickSrcSpan, hasBaseTypeVar, showPpr) +import Language.Haskell.Liquid.Misc +import Language.Fixpoint.Misc +import Language.Haskell.Liquid.Qualifier +import Control.DeepSeq + +import Debug.Trace (trace) +import IdInfo +----------------------------------------------------------------------- +------------- Constraint Generation: Toplevel ------------------------- +----------------------------------------------------------------------- + +generateConstraints :: GhcInfo -> CGInfo +generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info + where + act = consAct info + cfg = config $ spec info + + +consAct info + = do γ <- initEnv info + sflag <- scheck <$> get + foldM_ (consCBTop (derVars info)) γ (cbs info) + hcs <- hsCs <$> get + hws <- hsWfs <$> get + scss <- sCs <$> get + annot <- annotMap <$> get + scs <- if sflag then concat <$> mapM splitS (hcs ++ scss) + else return [] + let smap = if sflag then solveStrata scs else [] + 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 + modify $ \st -> st { fixCs = fcs } { fixWfs = fws } {annotMap = annot'} + +------------------------------------------------------------------------------------ +initEnv :: GhcInfo -> CG CGEnv +------------------------------------------------------------------------------------ +initEnv info + = do let tce = tcEmbeds sp + let fVars = impVars info ++ filter isConLikeId (snd <$> freeSyms sp) + defaults <- forM fVars $ \x -> liftM (x,) (trueTy $ varType x) + tyi <- tyConInfo <$> get + (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) + f2 <- refreshArgs' $ assm info -- assumed refinements (for imported vars) + f3 <- refreshArgs' $ vals asmSigs sp -- assumed refinedments (with `assume`) + f4 <- refreshArgs' $ vals ctors sp -- constructor refinements (for measures) + 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, 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 + foldM (++=) γ0 [("initEnv", x, y) | (x, y) <- concat $ tail bs] + where + sp = spec info + ialias = mkRTyConIAl $ ialiases sp + vals f = map (mapSnd val) . f + +refreshHoles vts = first catMaybes . unzip . map extract <$> mapM refreshHoles' vts +refreshHoles' (x,t) + | noHoles t = return (Nothing,x,t) + | otherwise = (Just $ F.symbol x,x,) <$> mapReftM tx t + where + tx r | hasHole r = refresh r + | otherwise = return r +extract (a,b,c) = (a,(b,c)) + +refreshArgs' = mapM (mapSndM refreshArgs) + +strataUnify :: [(Var, SpecType)] -> (Var, SpecType) -> (Var, SpecType) +strataUnify senv (x, t) = (x, maybe t (mappend t) pt) + where + pt = (fmap (\(U r p l) -> U mempty mempty l)) <$> L.lookup x senv + + +-- | TODO: All this *should* happen inside @Bare@ but appears +-- to happen after certain are signatures are @fresh@-ed, +-- which is why they are here. +predsUnify sp = second (addTyConInfo tce tyi) -- needed to eliminate some @RPropH@ + . unifyts penv -- needed to match up some @TyVars@ + where + tce = tcEmbeds sp + tyi = tyconEnv sp + penv = predEnv sp + +predEnv :: GhcSpec -> F.SEnv PrType +predEnv sp = F.fromListSEnv bs + where + bs = mapFst F.symbol <$> (dcs ++ assms) + dcs = concatMap mkDataConIdsTy pcs + pcs = [(x, dcPtoPredTy x y) | (x, y) <- dconsP sp] + assms = mapSnd (mapReft ur_pred . val) <$> tySigs sp + dcPtoPredTy :: DC.DataCon -> DataConP -> PrType + dcPtoPredTy dc = fmap ur_pred . dataConPSpecType dc + +unifyts penv (x, t) = (x, unify pt t) + where + pt = F.lookupSEnv x' penv + x' = F.symbol x +--------------------------------------------------------------------------------------- + +measEnv sp xts cbs lts asms hs + = CGE { loc = noSrcSpan + , renv = fromListREnv $ second (uRType . val) <$> meas sp + , syenv = F.fromListSEnv $ freeSyms sp + , fenv = initFEnv $ lts ++ (second (rTypeSort tce . val) <$> meas sp) + , recs = S.empty + , invs = mkRTyConInv $ invariants sp + , ial = mkRTyConIAl $ ialiases sp + , grtys = fromListREnv xts + , assms = fromListREnv asms + , emb = tce + , tgEnv = Tg.makeTagEnv cbs + , tgKey = Nothing + , trec = Nothing + , lcb = M.empty + , holes = fromListHEnv hs + } + where + tce = tcEmbeds sp + +assm = assm_grty impVars +grty = assm_grty defVars + +assm_grty f info = [ (x, val t) | (x, t) <- sigs, x `S.member` xs ] + where + 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] + 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)] + + +------------------------------------------------------------------------ +-- | Helpers: Reading/Extending Environment Bindings ------------------- +------------------------------------------------------------------------ + +data FEnv = FE { fe_binds :: !F.IBindEnv -- ^ Integer Keys for Fixpoint Environment + , fe_env :: !(F.SEnv F.Sort) -- ^ Fixpoint Environment + } + +insertFEnv (FE benv env) ((x, t), i) + = FE (F.insertsIBindEnv [i] benv) (F.insertSEnv x t env) + +insertsFEnv = L.foldl' insertFEnv + +initFEnv init = FE F.emptyIBindEnv $ F.fromListSEnv (wiredSortedSyms ++ init) + +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) + , fenv :: !FEnv -- ^ Fixpoint Environment + , recs :: !(S.HashSet Var) -- ^ recursive defs being processed (for annotations) + , 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 + , tgEnv :: !Tg.TagEnv -- ^ Map from top-level binders to fixpoint tag + , tgKey :: !(Maybe Tg.TagKey) -- ^ Current top-level binder + , trec :: !(Maybe (M.HashMap F.Symbol SpecType)) -- ^ Type of recursive function with decreasing constraints + , lcb :: !(M.HashMap F.Symbol CoreExpr) -- ^ Let binding that have not been checked + , holes :: !HEnv -- ^ Types with holes, will need refreshing + } -- deriving (Data, Typeable) + +instance PPrint CGEnv where + pprint = pprint . renv + +instance Show CGEnv where + show = showpp + +getTag :: CGEnv -> F.Tag +getTag γ = maybe Tg.defaultTag (`Tg.getTag` (tgEnv γ)) (tgKey γ) + +setLoc :: CGEnv -> SrcSpan -> CGEnv +γ `setLoc` src + | isGoodSrcSpan src = γ { loc = src } + | otherwise = γ + +withRecs :: CGEnv -> [Var] -> CGEnv +withRecs γ xs = γ { recs = foldl' (flip S.insert) (recs γ) xs } + +withTRec γ xts = γ' {trec = Just $ M.fromList xts' `M.union` trec'} + where γ' = γ `withRecs` (fst <$> xts) + trec' = fromMaybe M.empty $ trec γ + xts' = mapFst F.symbol <$> xts + +setBind :: CGEnv -> Tg.TagKey -> CGEnv +setBind γ k + | Tg.memTagEnv k (tgEnv γ) = γ { tgKey = Just k } + | otherwise = γ + + +isGeneric :: RTyVar -> SpecType -> Bool +isGeneric α t = all (\(c, α') -> (α'/=α) || isOrd c || isEq c ) (classConstrs t) + where classConstrs t = [(c, α') | (c, ts) <- tyClasses t + , t' <- ts + , α' <- freeTyVars t'] + isOrd = (ordClassName ==) . className + isEq = (eqClassName ==) . className + + +----------------------------------------------------------------- +------------------- Constraints: Types -------------------------- +----------------------------------------------------------------- + +data SubC = SubC { senv :: !CGEnv + , lhs :: !SpecType + , rhs :: !SpecType + } + | SubR { senv :: !CGEnv + , oblig :: !Oblig + , ref :: !RReft + } + +data WfC = WfC !CGEnv !SpecType + -- deriving (Data, Typeable) + +type FixSubC = F.SubC Cinfo +type FixWfC = F.WfC Cinfo + +instance PPrint SubC where + pprint c = pprint (senv c) + $+$ ((text " |- ") <+> ( (pprint (lhs c)) + $+$ text "<:" + $+$ (pprint (rhs c)))) + +instance PPrint WfC where + 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) + subS _ c = c + +------------------------------------------------------------ +------------------- Constraint Splitting ------------------- +------------------------------------------------------------ + +splitW :: WfC -> CG [FixWfC] + +splitW (WfC γ t@(RFun x t1 t2 _)) + = do ws <- bsplitW γ t + ws' <- splitW (WfC γ t1) + γ' <- (γ, "splitW") += (x, t1) + ws'' <- splitW (WfC γ' t2) + return $ ws ++ ws' ++ ws'' + +splitW (WfC γ t@(RAppTy t1 t2 _)) + = do ws <- bsplitW γ t + ws' <- splitW (WfC γ t1) + ws'' <- splitW (WfC γ t2) + return $ ws ++ ws' ++ ws'' + +splitW (WfC γ (RAllT _ r)) + = splitW (WfC γ r) + +splitW (WfC γ (RAllP _ r)) + = splitW (WfC γ r) + +splitW (WfC γ t@(RVar _ _)) + = bsplitW γ t + +splitW (WfC _ (RCls _ _)) + = return [] + +splitW (WfC γ t@(RApp _ ts rs _)) + = do ws <- bsplitW γ t + γ' <- γ `extendEnvWithVV` t + ws' <- concat <$> mapM splitW (map (WfC γ') ts) + ws'' <- concat <$> mapM (rsplitW γ) rs + return $ ws ++ ws' ++ ws'' + +splitW (WfC _ t) + = errorstar $ "splitW cannot handle: " ++ showpp t + +rsplitW _ (RPropP _ _) + = errorstar "Constrains: rsplitW for RPropP" +rsplitW γ (RProp ss t0) + = do γ' <- foldM (++=) γ [("rsplitC", x, ofRSort s) | (x, s) <- ss] + splitW $ WfC γ' t0 + +bsplitW :: CGEnv -> SpecType -> CG [FixWfC] +bsplitW γ t = pruneRefs <$> get >>= return . bsplitW' γ t + +bsplitW' γ t pflag + | F.isNonTrivialSortedReft r' = [F.wfC (fe_binds $ fenv γ) r' Nothing ci] + | otherwise = [] + where + r' = rTypeSortedReft' pflag γ t + ci = Ci (loc γ) Nothing + +mkSortedReft tce = F.RR . rTypeSort tce + +------------------------------------------------------------ +splitS :: SubC -> CG [([Stratum], [Stratum])] +bsplitS :: SpecType -> SpecType -> CG [([Stratum], [Stratum])] +------------------------------------------------------------ + +splitS (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2 + = splitS (SubC γ t1 t2) + +splitS (SubC γ t1 (REx x tx t2)) + = splitS (SubC γ t1 t2) + +splitS (SubC γ (REx x tx t1) t2) + = splitS (SubC γ t1 t2) + +splitS (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2 + = splitS (SubC γ t1 t2) + +splitS (SubC γ (RAllE x tx t1) t2) + = splitS (SubC γ t1 t2) + +splitS (SubC γ t1 (RAllE x tx t2)) + = splitS (SubC γ t1 t2) + +splitS (SubC γ (RRTy e r o t1) t2) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e + c1 <- splitS (SubR γ' o r) + c2 <- splitS (SubC γ t1 t2) + return $ c1 ++ c2 + +splitS (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) + = do cs <- bsplitS t1 t2 + cs' <- splitS (SubC γ r2 r1) + γ' <- (γ, "splitC") += (x2, r2) + let r1x2' = r1' `F.subst1` (x1, F.EVar x2) + cs'' <- splitS (SubC γ' r1x2' r2') + return $ cs ++ cs' ++ cs'' + +splitS (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) + = do cs <- bsplitS t1 t2 + cs' <- splitS (SubC γ r1 r2) + cs'' <- splitS (SubC γ r1' r2') + cs''' <- splitS (SubC γ r2' r1') + return $ cs ++ cs' ++ cs'' ++ cs''' + +splitS (SubC γ t1 (RAllP p t)) + = splitS $ SubC γ t1 t' + where t' = fmap (replacePredsWithRefs su) t + su = (uPVar p, pVartoRConc p) + +splitS (SubC _ t1@(RAllP _ _) t2) + = errorstar $ "Predicate in lhs of constrain:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2 + +splitS (SubC γ (RAllT α1 t1) (RAllT α2 t2)) + | α1 == α2 + = splitS $ SubC γ t1 t2 + | otherwise + = splitS $ SubC γ t1 t2' + where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2 + +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 c' t2s r2s _ = t2' + let tyInfo = rtc_info c + cscov <- splitSIndexed γ' t1s t2s $ covariantTyArgs tyInfo + cscon <- splitSIndexed γ' t2s t1s $ contravariantTyArgs tyInfo + cscov' <- rsplitSIndexed γ' r1s r2s $ covariantPsArgs tyInfo + cscon' <- rsplitSIndexed γ' r2s r1s $ contravariantPsArgs tyInfo + return $ cs ++ cscov ++ cscon ++ cscov' ++ cscon' + +splitS (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) + | a1 == a2 + = bsplitS t1 t2 + +splitS (SubC _ (RCls c1 _) (RCls c2 _)) | c1 == c2 + = return [] + +splitS c@(SubC _ t1 t2) + = errorstar $ "(Another Broken Test!!!) splitS unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2 + +splitS (SubR _ _ _) + = return [] + +splitSIndexed γ t1s t2s indexes + = concatMapM splitS (zipWith (SubC γ) t1s' t2s') + where t1s' = catMaybes $ (!?) t1s <$> indexes + t2s' = catMaybes $ (!?) t2s <$> indexes + +rsplitSIndexed γ t1s t2s indexes + = concatMapM (rsplitS γ) (safeZip "rsplitC" t1s' t2s') + where t1s' = catMaybes $ (!?) t1s <$> indexes + t2s' = catMaybes $ (!?) t2s <$> indexes + +bsplitS t1 t2 + = return $ [(s1, s2)] + where [s1, s2] = getStrata <$> [t1, t2] + +rsplitCS _ (RPropP _ _, RPropP _ _) + = errorstar "RefTypes.rsplitC on RPropP" + +rsplitS γ (t1@(RProp s1 r1), t2@(RProp s2 r2)) + = splitS (SubC γ (F.subst su r1) r2) + where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2] + +rsplitS _ _ + = errorstar "rspliS Rpoly - RPropP" + +------------------------------------------------------------ +splitC :: SubC -> CG [FixSubC] +------------------------------------------------------------ + +splitC (SubC γ (REx x tx t1) (REx x2 _ t2)) | x == x2 + = do γ' <- (γ, "addExBind 0") += (x, forallExprRefType γ tx) + splitC (SubC γ' t1 t2) + +splitC (SubC γ t1 (REx x tx t2)) + = do γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx) + let xs = grapBindsWithType tx γ + let t2' = splitExistsCases x xs tx t2 + splitC (SubC γ' t1 t2') + +-- existential at the left hand side is treated like forall +splitC z@(SubC γ (REx x tx t1) t2) + = do -- let tx' = traceShow ("splitC: " ++ showpp z) tx + γ' <- (γ, "addExBind 1") += (x, forallExprRefType γ tx) + splitC (SubC γ' t1 t2) + +splitC (SubC γ (RAllE x tx t1) (RAllE x2 _ t2)) | x == x2 + = do γ' <- (γ, "addExBind 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) + +splitC (SubC γ t1 (RAllE x tx t2)) + = do γ' <- (γ, "addExBind 2") += (x, forallExprRefType γ tx) + splitC (SubC γ' t1 t2) + +splitC (SubC γ (RRTy e r o t1) t2) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("splitS", x,t)) γ e + c1 <- splitC (SubR γ' o r ) + c2 <- splitC (SubC γ t1 t2) + return $ c1 ++ c2 + +splitC (SubC γ t1@(RFun x1 r1 r1' _) t2@(RFun x2 r2 r2' _)) + = do cs <- bsplitC γ t1 t2 + cs' <- splitC (SubC γ r2 r1) + γ' <- (γ, "splitC") += (x2, r2) + let r1x2' = r1' `F.subst1` (x1, F.EVar x2) + cs'' <- splitC (SubC γ' r1x2' r2') + return $ cs ++ cs' ++ cs'' + +splitC (SubC γ t1@(RAppTy r1 r1' _) t2@(RAppTy r2 r2' _)) + = do cs <- bsplitC γ t1 t2 + cs' <- splitC (SubC γ r1 r2) + cs'' <- splitC (SubC γ r1' r2') + cs''' <- splitC (SubC γ r2' r1') + return $ cs ++ cs' ++ cs'' ++ cs''' + +splitC (SubC γ t1 (RAllP p t)) + = splitC $ SubC γ t1 t' + where t' = fmap (replacePredsWithRefs su) t + su = (uPVar p, pVartoRConc p) + +splitC (SubC _ t1@(RAllP _ _) t2) + = errorstar $ "Predicate in lhs of constraint:" ++ showpp t1 ++ "\n<:\n" ++ showpp t2 + +splitC (SubC γ (RAllT α1 t1) (RAllT α2 t2)) + | α1 == α2 + = splitC $ SubC γ t1 t2 + | otherwise + = splitC $ SubC γ t1 t2' + where t2' = subsTyVar_meet' (α2, RVar α1 mempty) t2 + +splitC (SubC γ t1@(RApp _ _ _ _) t2@(RApp _ _ _ _)) + = do (t1',t2') <- unifyVV t1 t2 + cs <- bsplitC γ t1' t2' + γ' <- γ `extendEnvWithVV` t1' + let RApp c t1s r1s _ = t1' + let RApp c' t2s r2s _ = t2' + let tyInfo = rtc_info c + cscov <- splitCIndexed γ' t1s t2s $ covariantTyArgs tyInfo + cscon <- splitCIndexed γ' t2s t1s $ contravariantTyArgs tyInfo + cscov' <- rsplitCIndexed γ' r1s r2s $ covariantPsArgs tyInfo + cscon' <- rsplitCIndexed γ' r2s r1s $ contravariantPsArgs tyInfo + return $ cs ++ cscov ++ cscon ++ cscov' ++ cscon' + +splitC (SubC γ t1@(RVar a1 _) t2@(RVar a2 _)) + | a1 == a2 + = bsplitC γ t1 t2 + +splitC (SubC _ (RCls c1 _) (RCls c2 _)) | c1 == c2 + = return [] + +splitC c@(SubC _ t1 t2) + = errorstar $ "(Another Broken Test!!!) splitc unexpected: " ++ showpp t1 ++ "\n\n" ++ showpp t2 + +splitC (SubR γ o r) + = do fg <- pruneRefs <$> get + let r1' = if fg then pruneUnsortedReft γ'' r1 else r1 + return $ F.subC γ' F.PTrue r1' r2 Nothing tag ci + where + γ'' = fe_env $ fenv γ + γ' = fe_binds $ fenv γ + r1 = F.RR s $ F.toReft r + r2 = F.RR s $ F.Reft (vv, [F.RConc $ F.PBexp $ F.EVar vv]) + vv = "vvRec" + s = F.FApp F.boolFTyCon [] + ci = Ci src err + err = Just $ ErrAssType src o (text $ show o ++ "type error") r + tag = getTag γ + src = loc γ + +splitCIndexed γ t1s t2s indexes + = concatMapM splitC (zipWith (SubC γ) t1s' t2s') + where + t1s' = catMaybes $ (!?) t1s <$> indexes + t2s' = catMaybes $ (!?) t2s <$> indexes + +rsplitCIndexed γ t1s t2s indexes + = concatMapM (rsplitC γ) (safeZip "rsplitC" t1s'' t2s'') + where + t1s' = catMaybes $ (!?) t1s <$> indexes + t2s' = catMaybes $ (!?) t2s <$> indexes + (t1s'', t2s'') = pad "rsplitCIndexed" F.top t1s' t2s' + + +bsplitC γ t1 t2 + = checkStratum γ t1 t2 >> pruneRefs <$> get >>= return . bsplitC' γ t1 t2 + +checkStratum γ t1 t2 + | s1 <:= s2 = return () + | otherwise = addWarning wrn + where [s1, s2] = getStrata <$> [t1, t2] + wrn = "Stratum Error : " ++ show s1 ++ " > " ++ show s2 ++ + "\tat " ++ show (pprint $ loc γ) + +bsplitC' γ t1 t2 pflag + | F.isFunctionSortedReft r1' && F.isNonTrivialSortedReft r2' + = F.subC γ' F.PTrue (r1' {F.sr_reft = mempty}) r2' Nothing tag ci + | F.isNonTrivialSortedReft r2' + = F.subC γ' F.PTrue r1' r2' Nothing tag ci + | otherwise + = [] + where + γ' = fe_binds $ fenv γ + r1' = rTypeSortedReft' pflag γ t1 + r2' = rTypeSortedReft' pflag γ t2 + ci = Ci src err + tag = getTag γ + err = Just $ ErrSubType src (text "subtype") g t1 t2 + src = loc γ + REnv g = renv γ + + + +unifyVV t1@(RApp c1 _ _ _) t2@(RApp c2 _ _ _) + = do vv <- (F.vv . Just) <$> fresh + return $ (shiftVV t1 vv, (shiftVV t2 vv) ) -- {rt_pargs = r2s'}) + +rsplitC _ (RPropP _ _, RPropP _ _) + = errorstar "RefTypes.rsplitC on RPropP" + +rsplitC γ (t1@(RProp s1 r1), t2@(RProp s2 r2)) + = do γ' <- foldM (++=) γ [("rsplitC1", x, ofRSort s) | (x, s) <- s2] + splitC (SubC γ' (F.subst su r1) r2) + where su = F.mkSubst [(x, F.EVar y) | ((x,_), (y,_)) <- zip s1 s2] + +rsplitC _ _ + = errorstar "rsplit Rpoly - RPropP" + + +----------------------------------------------------------- +-------------------- Generation: Types -------------------- +----------------------------------------------------------- + +data CGInfo = CGInfo { hsCs :: ![SubC] -- ^ subtyping constraints over RType + , 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 + , fixWfs :: ![FixWfC] -- ^ wellformedness constraints over Sort (post-splitting) + , globals :: !F.FEnv -- ^ ? global measures + , freshIndex :: !Integer -- ^ counter for generating fresh KVars + , binds :: !F.BindEnv -- ^ set of environment binders + , annotMap :: !(AnnInfo (Annot SpecType)) -- ^ source-position annotation map + , tyConInfo :: !(M.HashMap TC.TyCon RTyCon) -- ^ information about type-constructors + , specQuals :: ![F.Qualifier] -- ^ ? qualifiers in source files + , specDecr :: ![(Var, [Int])] -- ^ ? FIX THIS + , 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 + , 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 (?) + , scheck :: !Bool -- ^ Check Strata (?) + , pruneRefs :: !Bool -- ^ prune unsorted refinements + , logWarn :: ![String] -- ^ ? FIX THIS + , kvProf :: !KVProf -- ^ Profiling distribution of KVars + , recCount :: !Int -- ^ number of recursive functions seen (for benchmarks) + } -- deriving (Data, Typeable) + +instance PPrint CGInfo where + pprint cgi = {-# SCC "ppr_CGI" #-} ppr_CGInfo cgi + +ppr_CGInfo cgi + = (text "*********** Constraint Information ***********") + -- -$$ (text "*********** Haskell SubConstraints ***********") + -- -$$ (pprintLongList $ hsCs cgi) + -- -$$ (text "*********** Haskell WFConstraints ************") + -- -$$ (pprintLongList $ hsWfs cgi) + -- -$$ (text "*********** Fixpoint SubConstraints **********") + -- -$$ (F.toFix $ fixCs cgi) + -- -$$ (text "*********** Fixpoint WFConstraints ************") + -- -$$ (F.toFix $ fixWfs cgi) + -- -$$ (text "*********** Fixpoint Kut Variables ************") + -- -$$ (F.toFix $ kuts cgi) + -- -$$ (text "*********** Literals in Source ************") + -- -$$ (pprint $ lits cgi) + -- -$$ (text "*********** KVar Distribution *****************") + -- -$$ (pprint $ kvProf cgi) + -- -$$ (text "Recursive binders:" <+> pprint (recCount cgi)) + +type CG = State CGInfo + +initCGI cfg info = CGInfo { + hsCs = [] + , sCs = [] + , hsWfs = [] + , fixCs = [] + , isBind = [] + , fixWfs = [] + , globals = globs + , freshIndex = 0 + , binds = F.emptyBindEnv + , annotMap = AI M.empty + , tyConInfo = tyi + , specQuals = qualifiers spc ++ specificationQualifiers (maxParams cfg) (info {spec = spec'}) + , tyConEmbed = tce + , kuts = F.ksEmpty + , lits = coreBindLits tce info + , termExprs = M.fromList $ texprs spc + , specDecr = decr spc + , specLVars = lvars spc + , specLazy = lazy spc + , tcheck = not $ notermination cfg + , scheck = strata cfg + , pruneRefs = not $ noPrune cfg + , logWarn = [] + , kvProf = emptyKVProf + , recCount = 0 + } + where + tce = tcEmbeds spc + spc = spec info + spec' = spc { tySigs = [ (x, addTyConInfo tce tyi <$> t) | (x, t) <- tySigs spc] + , asmSigs = [ (x, addTyConInfo tce tyi <$> t) | (x, t) <- asmSigs spc]} + tyi = tyconEnv spc -- EFFECTS HEREHEREHERE makeTyConInfo (tconsP spc) + globs = F.fromListSEnv . map mkSort $ meas spc + mkSort = mapSnd (rTypeSortedReft tce . val) + +coreBindLits tce info + = sortNub $ [ (val x, so) | (_, Just (F.ELit x so)) <- lconsts] + ++ [ (dconToSym dc, dconToSort dc) | dc <- dcons] + where + lconsts = literalConst tce <$> literals (cbs info) + dcons = filter isDCon $ impVars info + dconToSort = typeSort tce . expandTypeSynonyms . varType + dconToSym = dataConSymbol . idDataCon + isDCon x = isDataConWorkId x && not (hasBaseTypeVar x) + +extendEnvWithVV γ t + | F.isNontrivialVV vv + = (γ, "extVV") += (vv, t) + | otherwise + = return γ + where vv = rTypeValueVar t + +{- see tests/pos/polyfun for why you need everything in fixenv -} +addCGEnv :: (SpecType -> SpecType) -> CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv +addCGEnv tx γ (_, x, t') + = do idx <- fresh + let t = tx $ normalize γ {-x-} idx t' + let γ' = γ { renv = insertREnv x t (renv γ) } + pflag <- pruneRefs <$> get + is <- if isBase t + then liftM single $ addBind x $ rTypeSortedReft' pflag γ' t + else addClassBind t + return $ γ' { fenv = insertsFEnv (fenv γ) is } + +(++=) :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv +(++=) γ = addCGEnv (addRTyConInv (M.unionWith mappend (invs γ) (ial γ))) γ + +addSEnv :: CGEnv -> (String, F.Symbol, SpecType) -> CG CGEnv +addSEnv γ = addCGEnv (addRTyConInv (invs γ)) γ + +rTypeSortedReft' pflag γ + | pflag + = pruneUnsortedReft (fe_env $ fenv γ) . f + | otherwise + = f + where f = rTypeSortedReft (emb γ) + +(+++=) :: (CGEnv, String) -> (F.Symbol, CoreExpr, SpecType) -> CG CGEnv + +(γ, msg) +++= (x, e, t) = (γ{lcb = M.insert x e (lcb γ)}, "+++=") += (x, t) + +(+=) :: (CGEnv, String) -> (F.Symbol, SpecType) -> CG CGEnv +(γ, msg) += (x, r) + | x == F.dummySymbol + = return γ + | x `memberREnv` (renv γ) + = err + | otherwise + = γ ++= (msg, x, r) + where err = errorstar $ msg ++ " Duplicate binding for " + ++ F.symbolString x + ++ "\n New: " ++ showpp r + ++ "\n Old: " ++ showpp (x `lookupREnv` (renv γ)) + +γ -= x = γ {renv = deleteREnv x (renv γ), lcb = M.delete x (lcb γ)} + +(??=) :: CGEnv -> F.Symbol -> CG SpecType +γ ??= x + = case M.lookup x (lcb γ) of + Just e -> consE (γ-=x) e + Nothing -> refreshTy $ γ ?= x + +(?=) :: CGEnv -> F.Symbol -> SpecType +γ ?= x = fromMaybe err $ lookupREnv x (renv γ) + where err = errorstar $ "EnvLookup: unknown " + ++ showpp x + ++ " in renv " + ++ showpp (renv γ) + +normalize' γ x idx t = addRTyConInv (M.unionWith mappend (invs γ) (ial γ)) $ normalize γ idx t + +normalize γ idx + = normalizeVV idx + . normalizePds + +normalizeVV idx t@(RApp _ _ _ _) + | not (F.isNontrivialVV (rTypeValueVar t)) + = shiftVV t (F.vv $ Just idx) + +normalizeVV _ t + = t + + +addBind :: F.Symbol -> F.SortedReft -> CG ((F.Symbol, F.Sort), F.BindId) +addBind x r + = do st <- get + let (i, bs') = F.insertBindEnv x r (binds st) + put $ st { binds = bs' } + 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 + +-- RJ: What is this `isBind` business? +pushConsBind act + = do modify $ \s -> s { isBind = False : isBind s } + z <- act + modify $ \s -> s { isBind = tail (isBind s) } + return z + +addC :: SubC -> String -> CG () +addC !c@(SubC γ t1 t2) _msg + = do -- trace ("addC at " ++ show (loc γ) ++ _msg++ showpp t1 ++ "\n <: \n" ++ showpp t2 ) $ + modify $ \s -> s { hsCs = c : (hsCs s) } + bflag <- safeHead True . isBind <$> get + sflag <- scheck <$> get + if bflag && sflag + then modify $ \s -> s {sCs = (SubC γ t2 t1) : (sCs s) } + else return () + where + safeHead a [] = a + safeHead _ (x:xs) = x + + +addC !c _msg + = modify $ \s -> s { hsCs = c : (hsCs s) } + +addPost γ (RRTy e r OInv t) + = do γ' <- foldM (\γ (x, t) -> γ `addSEnv` ("addPost", x,t)) γ e + addC (SubR γ' OInv r) "precondition" >> return t + +addPost γ (RRTy e r o t) + = do γ' <- foldM (\γ (x, t) -> γ ++= ("addPost", x,t)) γ e + addC (SubR γ' o r) "precondition" >> return t +addPost _ t + = return t + +addW :: WfC -> CG () +addW !w = modify $ \s -> s { hsWfs = w : (hsWfs s) } + +addWarning :: String -> CG () +addWarning w = modify $ \s -> s { logWarn = w : (logWarn s) } + +-- | Used for annotation binders (i.e. at binder sites) + +addIdA :: Var -> Annot SpecType -> CG () +addIdA !x !t = modify $ \s -> s { annotMap = upd $ annotMap s } + where + loc = getSrcSpan x + upd m@(AI z) = if boundRecVar loc m then m else addA loc (Just x) t m + -- loc = traceShow ("addIdA: " ++ show x ++ " :: " ++ showpp t ++ " at ") $ getSrcSpan x + +boundRecVar l (AI m) = not $ null [t | (_, AnnRDf t) <- M.lookupDefault [] l m] + + +-- | Used for annotating reads (i.e. at Var x sites) + +addLocA :: Maybe Var -> SrcSpan -> Annot SpecType -> CG () +addLocA !xo !l !t + = modify $ \s -> s { annotMap = addA l xo t $ annotMap s } + +-- | Used to update annotations for a location, due to (ghost) predicate applications + +updateLocA (_:_) (Just l) t = addLocA Nothing l (AnnUse t) +updateLocA _ _ _ = return () + +addA !l xo@(Just _) !t (AI m) + | isGoodSrcSpan l + = AI $ inserts l (T.pack . showPpr <$> xo, t) m +addA !l xo@Nothing !t (AI m) + | l `M.member` m -- only spans known to be variables + = AI $ inserts l (T.pack . showPpr <$> xo, t) m +addA _ _ _ !a + = a + +------------------------------------------------------------------- +------------------------ Generation: Freshness -------------------- +------------------------------------------------------------------- + +-- | Right now, we generate NO new pvars. Rather than clutter code +-- with `uRType` calls, put it in one place where the above +-- invariant is /obviously/ enforced. +-- Constraint generation should ONLY use @freshTy_type@ and @freshTy_expr@ + +freshTy_type :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_type k e τ = freshTy_reftype k $ ofType τ + +freshTy_expr :: KVKind -> CoreExpr -> Type -> CG SpecType +freshTy_expr k e _ = freshTy_reftype k $ exprRefType e + +freshTy_reftype :: KVKind -> SpecType -> CG SpecType +-- freshTy_reftype k t = do t <- refresh =<< fixTy t +-- addKVars k t +-- return t + +freshTy_reftype k t = (fixTy t >>= refresh) =>> addKVars k + +-- | Used to generate "cut" kvars for fixpoint. Typically, KVars for recursive +-- definitions, and also to update the KVar profile. + +addKVars :: KVKind -> SpecType -> CG () +addKVars !k !t = do when (True) $ modify $ \s -> s { kvProf = updKVProf k kvars (kvProf s) } + when (isKut k) $ modify $ \s -> s { kuts = F.ksUnion kvars (kuts s) } + where + kvars = sortNub $ specTypeKVars t + +isKut :: KVKind -> Bool +isKut RecBindE = True +isKut _ = False + +specTypeKVars :: SpecType -> [F.Symbol] +specTypeKVars = foldReft ((++) . (F.reftKVars . ur_reft)) [] + +trueTy :: Type -> CG SpecType +trueTy = ofType' >=> true + +ofType' :: Type -> CG SpecType +ofType' = fixTy . ofType + +fixTy :: SpecType -> CG SpecType +fixTy t = do tyi <- tyConInfo <$> get + tce <- tyConEmbed <$> get + return $ addTyConInfo tce tyi t + +refreshArgsTop :: (Var, SpecType) -> CG SpecType +refreshArgsTop (x, t) + = do (t', su) <- refreshArgsSub t + modify $ \s -> s {termExprs = M.adjust (F.subst su <$>) x $ termExprs s} + return t' + +refreshArgs :: SpecType -> CG SpecType +refreshArgs t + = fst <$> refreshArgsSub t + +refreshArgsSub :: SpecType -> CG (SpecType, F.Subst) +refreshArgsSub t + = do ts <- mapM refreshArgs ts_u + xs' <- mapM (\_ -> fresh) xs + let sus = F.mkSubst <$> (L.inits $ zip xs (F.EVar <$> xs')) + let su = last sus + let ts' = zipWith F.subst sus ts + let t' = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts', ty_res = F.subst su tbd} + return (t', su) + where + trep = toRTypeRep t + xs = ty_binds trep + ts_u = ty_args trep + tbd = ty_res trep + +instance Freshable CG Integer where + fresh = do s <- get + let n = freshIndex s + put $ s { freshIndex = n + 1 } + return n + + +------------------------------------------------------------------------------- +----------------------- TERMINATION TYPE -------------------------------------- +------------------------------------------------------------------------------- + +makeDecrIndex :: (Var, SpecType)-> CG [Int] +makeDecrIndex (x, t) + = do hint <- checkHint' . L.lookup x . specDecr <$> get + case dindex of + Nothing -> addWarning msg >> return [] + Just i -> return $ fromMaybe [i] hint + where + ts = ty_args $ toRTypeRep t + checkHint' = checkHint x ts isDecreasing + dindex = L.findIndex isDecreasing ts + msg = printf "%s: No decreasing parameter" $ showPpr (getSrcSpan x) + +recType ((_, []), (_, [], t)) + = t + +recType ((vs, indexc), (x, index, t)) + = makeRecType t v dxt index + where v = (vs !!) <$> indexc + dxt = (xts !!) <$> index + loc = showPpr (getSrcSpan x) + xts = zip (ty_binds trep) (ty_args trep) + trep = toRTypeRep t + msg' = printf "%s: No decreasing argument on %s with %s" + msg = printf "%s: No decreasing parameter" loc + loc (showPpr x) (showPpr vs) + +checkIndex (x, vs, t, index) + = do mapM_ (safeLogIndex msg' vs) index + mapM (safeLogIndex msg ts) index + where + loc = showPpr (getSrcSpan x) + ts = ty_args $ toRTypeRep t + msg' = printf "%s: No decreasing argument on %s with %s" loc (showPpr x) (showPpr vs) + msg = printf "%s: No decreasing parameter" loc + +makeRecType t vs dxs is + = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'} + where + (xs', ts') = unzip $ replaceN (last is) (makeDecrType vdxs) xts + vdxs = zip vs dxs + xts = zip (ty_binds trep) (ty_args trep) + trep = toRTypeRep t + +safeLogIndex err ls n + | n >= length ls = addWarning err >> return Nothing + | otherwise = return $ Just $ ls !! n + +checkHint _ _ _ Nothing + = Nothing + +checkHint x ts f (Just ns) | L.sort ns /= ns + = errorstar $ printf "%s: The hints should be increasing" loc + where loc = showPpr $ getSrcSpan x + +checkHint x ts f (Just ns) + = Just $ catMaybes (checkValidHint x ts f <$> ns) + +checkValidHint x ts f n + | n < 0 || n >= length ts = errorstar err + | f (ts L.!! n) = Just n + | otherwise = errorstar err + where err = printf "%s: Invalid Hint %d for %s" loc (n+1) (showPpr x) + loc = showPpr $ getSrcSpan x + +------------------------------------------------------------------- +-------------------- Generation: Corebind ------------------------- +------------------------------------------------------------------- +consCBTop :: [Var] -> CGEnv -> CoreBind -> CG CGEnv +consCBLet :: CGEnv -> CoreBind -> CG CGEnv +------------------------------------------------------------------- + +consCBLet γ cb + = do oldtcheck <- tcheck <$> get + strict <- specLazy <$> get + let tflag = oldtcheck + let isStr = tcond cb strict + modify $ \s -> s{tcheck = tflag && isStr} + γ' <- consCB (tflag && isStr) isStr γ cb + modify $ \s -> s{tcheck = oldtcheck} + return γ' + +consCBTop dVs γ cb | isDerived + = do ts <- mapM trueTy (varType <$> xs) + foldM (\γ xt -> (γ, "derived") += xt) γ (zip xs' ts) + where isDerived = all (`elem` dVs) xs + xs = bindersOf cb + xs' = F.symbol <$> xs + +consCBTop _ γ cb + = do oldtcheck <- tcheck <$> get + strict <- specLazy <$> get + let tflag = oldtcheck + let isStr = tcond cb strict + modify $ \s -> s{tcheck = tflag && isStr} + γ' <- consCB (tflag && isStr) isStr γ cb + modify $ \s -> s{tcheck = oldtcheck} + return γ' + +tcond cb strict + = not $ any (\x -> S.member x strict || isInternal x) (binds cb) + where binds (NonRec x _) = [x] + binds (Rec xes) = fst $ unzip xes + +------------------------------------------------------------------- +consCB :: Bool -> Bool -> CGEnv -> CoreBind -> CG CGEnv +------------------------------------------------------------------- + +consCBSizedTys tflag γ (Rec xes) + = do xets'' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) + sflag <- scheck <$> get + let cmakeFinType = if sflag then makeFinType else id + let cmakeFinTy = if sflag then makeFinTy else snd + let xets = mapThd3 (fmap cmakeFinType) <$> xets'' + ts' <- mapM refreshArgs $ (fromAsserted . thd3 <$> xets) + let vs = zipWith collectArgs ts' es + is <- checkSameLens <$> mapM makeDecrIndex (zip xs ts') + let ts = cmakeFinTy <$> zip is ts' + let xeets = (\vis -> [(vis, x) | x <- zip3 xs is ts]) <$> (zip vs is) + checkEqTypes . L.transpose <$> mapM checkIndex (zip4 xs vs ts is) + let rts = (recType <$>) <$> xeets + let xts = zip xs (Asserted <$> ts) + γ' <- foldM extender γ xts + let γs = [γ' `withTRec` (zip xs rts') | rts' <- rts] + let xets' = zip3 xs es (Asserted <$> ts) + mapM_ (uncurry $ consBind True) (zip γs xets') + return γ' + where + dmapM f = sequence . (mapM f <$>) + (xs, es) = unzip xes + collectArgs = collectArguments . length . ty_binds . toRTypeRep + checkEqTypes = map (checkAll err1 toRSort . catMaybes) + checkSameLens = checkAll err2 length + err1 = printf "%s: The decreasing parameters should be of same type" loc + err2 = printf "%s: All Recursive functions should have the same number of decreasing parameters" loc + loc = showPpr $ getSrcSpan (head xs) + + checkAll _ _ [] = [] + checkAll err f (x:xs) + | all (==(f x)) (f <$> xs) = (x:xs) + | otherwise = errorstar err + +consCBWithExprs γ (Rec xes) + = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) + texprs <- termExprs <$> get + let xtes = catMaybes $ (`lookup` texprs) <$> xs + sflag <- scheck <$> get + let cmakeFinType = if sflag then makeFinType else id + let cmakeFinTy = if sflag then makeFinTy else snd + let xets = mapThd3 (fmap cmakeFinType) <$> xets' + let ts = safeFromAsserted err . thd3 <$> xets + ts' <- mapM refreshArgs ts + let xts = zip xs (Asserted <$> ts') + γ' <- foldM extender γ xts + let γs = makeTermEnvs γ' xtes xes ts ts' + let xets' = zip3 xs es (Asserted <$> ts') + mapM_ (uncurry $ consBind True) (zip γs xets') + return γ' + where (xs, es) = unzip xes + lookup k m | Just x <- M.lookup k m = Just (k, x) + | otherwise = Nothing + err = "Constant: consCBWithExprs" + +makeFinTy (ns, t) = fromRTypeRep $ trep {ty_args = args'} + where trep = toRTypeRep t + args' = mapNs ns makeFinType $ ty_args trep + + +makeTermEnvs γ xtes xes ts ts' = withTRec γ . zip xs <$> rts + where + vs = zipWith collectArgs ts es + ys = (fst3 . bkArrowDeep) <$> ts + ys' = (fst3 . bkArrowDeep) <$> ts' + sus' = zipWith mkSub ys ys' + sus = zipWith mkSub ys ((F.symbol <$>) <$> vs) + ess = (\x -> (safeFromJust (err x) $ (x `L.lookup` xtes))) <$> xs + tes = zipWith (\su es -> F.subst su <$> es) sus ess + tes' = zipWith (\su es -> F.subst su <$> es) sus' ess + rss = zipWith makeLexRefa tes' <$> (repeat <$> tes) + rts = zipWith addTermCond ts' <$> rss + (xs, es) = unzip xes + mkSub ys ys' = F.mkSubst [(x, F.EVar y) | (x, y) <- zip ys ys'] + collectArgs = collectArguments . length . ty_binds . toRTypeRep + err x = "Constant: makeTermEnvs: no terminating expression for " ++ showPpr x + + + +consCB tflag _ γ (Rec xes) | tflag + = do texprs <- termExprs <$> get + modify $ \i -> i { recCount = recCount i + length xes } + let xxes = catMaybes $ (`lookup` texprs) <$> xs + if null xxes + then consCBSizedTys tflag γ (Rec xes) + else check xxes <$> consCBWithExprs γ (Rec xes) + where xs = fst $ unzip xes + check ys r | length ys == length xs = r + | otherwise = errorstar err + err = printf "%s: Termination expressions should be provided for ALL mutual recursive functions" loc + loc = showPpr $ getSrcSpan (head xs) + lookup k m | Just x <- M.lookup k m = Just (k, x) + | otherwise = Nothing + +consCB _ str γ (Rec xes) | not str + = do xets' <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) + sflag <- scheck <$> get + let cmakeDivType = if sflag then makeDivType else id + let xets = mapThd3 (fmap cmakeDivType) <$> xets' + modify $ \i -> i { recCount = recCount i + length xes } + let xts = [(x, to) | (x, _, to) <- xets] + γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts + mapM_ (consBind True γ') xets + return γ' + +consCB _ _ γ (Rec xes) + = do xets <- forM xes $ \(x, e) -> liftM (x, e,) (varTemplate γ (x, Just e)) + modify $ \i -> i { recCount = recCount i + length xes } + let xts = [(x, to) | (x, _, to) <- xets] + γ' <- foldM extender (γ `withRecs` (fst <$> xts)) xts + mapM_ (consBind True γ') xets + return γ' + +consCB _ _ γ (NonRec x e) + = do to <- varTemplate γ (x, Nothing) + to' <- consBind False γ (x, e, to) >>= (addPostTemplate γ) + extender γ (x, to') + +consBind isRec γ (x, e, Asserted spect) + = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x + (_,πs,_,_) = bkUniv spect + γπ <- foldM addPToEnv γ' πs + cconsE γπ e spect + when (F.symbol x `elemHEnv` holes γ) $ + -- have to add the wf constraint here for HOLEs so we have the proper env + addW $ WfC γπ $ fmap killSubst spect + addIdA x (defAnn isRec spect) + return $ Asserted spect -- Nothing + +consBind isRec γ (x, e, Assumed spect) + = do let γ' = (γ `setLoc` getSrcSpan x) `setBind` x + γπ <- foldM addPToEnv γ' πs + cconsE γπ e =<< true spect + addIdA x (defAnn isRec spect) + return $ Asserted spect -- Nothing + where πs = ty_preds $ toRTypeRep spect + +consBind isRec γ (x, e, Unknown) + = do t <- consE (γ `setBind` x) e + addIdA x (defAnn isRec t) + return $ Asserted t + +noHoles = and . foldReft (\r bs -> not (hasHole r) : bs) [] + +killSubst :: RReft -> RReft +killSubst = fmap tx + where + tx (F.Reft (s, rs)) = F.Reft (s, map f rs) + f (F.RKvar k _) = F.RKvar k mempty + f (F.RConc p) = F.RConc p + +defAnn True = AnnRDf +defAnn False = AnnDef + +addPToEnv γ π + = do γπ <- γ ++= ("addSpec1", pname π, pvarRType π) + foldM (++=) γπ [("addSpec2", x, ofRSort t) | (t, x, _) <- pargs π] + +extender γ (x, Asserted t) = γ ++= ("extender", F.symbol x, t) +extender γ (x, Assumed t) = γ ++= ("extender", F.symbol x, t) +extender γ _ = return γ + +addBinders γ0 x' cbs = foldM (++=) (γ0 -= x') [("addBinders", x, t) | (x, t) <- cbs] + +data Template a = Asserted a | Assumed a | Unknown deriving (Functor) + +deriving instance (Show a) => (Show (Template a)) + + +addPostTemplate γ (Asserted t) = Asserted <$> addPost γ t +addPostTemplate γ (Assumed t) = Assumed <$> addPost γ t +addPostTemplate γ Unknown = return Unknown + +fromAsserted (Asserted t) = t +safeFromAsserted msg (Asserted t) = t + +-- | @varTemplate@ is only called with a `Just e` argument when the `e` +-- corresponds to the body of a @Rec@ binder. +varTemplate :: CGEnv -> (Var, Maybe CoreExpr) -> CG (Template SpecType) +varTemplate γ (x, eo) + = case (eo, lookupREnv (F.symbol x) (grtys γ), lookupREnv (F.symbol x) (assms γ)) of + (_, Just t, _) -> Asserted <$> refreshArgsTop (x, t) + (_, _, Just t) -> Assumed <$> refreshArgsTop (x, t) + (Just e, _, _) -> do t <- freshTy_expr RecBindE e (exprType e) + addW (WfC γ t) + Asserted <$> refreshArgsTop (x, t) + (_, _, _) -> return Unknown + +------------------------------------------------------------------- +-------------------- Generation: Expression ----------------------- +------------------------------------------------------------------- + +----------------------- Type Checking ----------------------------- +cconsE :: CGEnv -> Expr Var -> SpecType -> CG () +------------------------------------------------------------------- +cconsE γ e@(Let b@(NonRec x _) ee) t + = do sp <- specLVars <$> get + if (x `S.member` sp) || isDefLazyVar x + then cconsLazyLet γ e t + else do γ' <- consCBLet γ b + cconsE γ' ee t + where + isDefLazyVar = L.isPrefixOf "fail" . showPpr + +cconsE γ (Let b e) t + = do γ' <- consCBLet γ b + cconsE γ' e t + +cconsE γ (Case e x _ cases) t + = do γ' <- consCBLet γ (NonRec x e) + forM_ cases $ cconsCase γ' x t nonDefAlts + where + nonDefAlts = [a | (a, _, _) <- cases, a /= DEFAULT] + +cconsE γ (Lam α e) (RAllT α' t) | isTyVar α + = cconsE γ e $ subsTyVar_meet' (α', rVar α) t + +cconsE γ (Lam x e) (RFun y ty t _) + | not (isTyVar x) + = do γ' <- (γ, "cconsE") += (F.symbol x, ty) + cconsE γ' e (t `F.subst1` (y, F.EVar $ F.symbol x)) + addIdA x (AnnDef ty) + +cconsE γ (Tick tt e) t + = cconsE (γ `setLoc` tickSrcSpan tt) e t + +cconsE γ e@(Cast e' _) t + = do t' <- castTy γ (exprType e) e' + addC (SubC γ t' t) ("cconsE Cast" ++ showPpr e) + +cconsE γ e (RAllP p t) + = cconsE γ e t' + where + t' = replacePredsWithRefs su <$> t + su = (uPVar p, pVartoRConc p) + +cconsE γ e t + = do te <- consE γ e + te' <- instantiatePreds γ e te >>= addPost γ + addC (SubC γ te' t) ("cconsE" ++ showPpr e) + + +------------------------------------------------------------------- +-- | @instantiatePreds@ peels away the universally quantified @PVars@ +-- of a @RType@, generates fresh @Ref@ for them and substitutes them +-- in the body. + +instantiatePreds γ e t0@(RAllP π t) + = do r <- freshPredRef γ e π + let πZZ = {- traceShow ("instantiatePreds 1") -} π + let tZZ = {- traceShow ("instantiatePreds 2") -} t + let rZZ = {- traceShow ("instantiatePreds 3") -} r + let t' = replacePreds "consE" tZZ [(πZZ, rZZ)] + instantiatePreds γ e t' + +instantiatePreds _ _ t0 + = return t0 + +------------------------------------------------------------------- +-- | @instantiateStrata@ generates fresh @Strata@ vars and substitutes +-- them inside the body of the type. + +instantiateStrata ls t = substStrata t ls <$> mapM (\_ -> fresh) ls + +substStrata t ls ls' = F.substa f t + where + f x = fromMaybe x $ L.lookup x su + su = zip ls ls' + +------------------------------------------------------------------- + +cconsLazyLet γ (Let (NonRec x ex) e) t + = do tx <- trueTy (varType x) + γ' <- (γ, "Let NonRec") +++= (x', ex, tx) + cconsE γ' e t + where + xr = singletonReft x + x' = F.symbol x + + +------------------------------------------------------------------- +-- | Type Synthesis ----------------------------------------------- +------------------------------------------------------------------- +consE :: CGEnv -> Expr Var -> CG SpecType +------------------------------------------------------------------- + +consE γ (Var x) + = do t <- varRefType γ x + addLocA (Just x) (loc γ) (varAnn γ x t) + return t + +consE γ (Lit c) + = refreshVV $ uRType $ literalFRefType (emb γ) c + +consE γ e'@(App e (Type τ)) + = do RAllT α te <- checkAll ("Non-all TyApp with expr", e) <$> consE γ e + t <- if isGeneric α te then freshTy_type TypeInstE e τ else trueTy τ + addW $ WfC γ t + t' <- refreshVV t + instantiatePreds γ e' $ subsTyVar_meet' (α, t') te + +consE γ e'@(App e a) + = do ([], πs, ls, te) <- bkUniv <$> consE γ e + te0 <- instantiatePreds γ e' $ foldr RAllP te πs + te' <- instantiateStrata ls te0 + (γ', te'') <- dropExists γ te' + 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) + +consE γ (Lam α e) | isTyVar α + = liftM (RAllT (rTyVar α)) (consE γ e) + +consE γ e@(Lam x e1) + = do tx <- freshTy_type LamE (Var x) τx + γ' <- ((γ, "consE") += (F.symbol x, tx)) + t1 <- consE γ' e1 + addIdA x $ AnnDef tx + addW $ WfC γ tx + return $ rFun (F.symbol x) tx t1 + where + FunTy τx _ = exprType e + +-- EXISTS-BASED CONSTRAINTS HEREHEREHEREHERE +-- Currently suppressed because they break all sorts of invariants, +-- e.g. for `unfoldR`... +-- consE γ e@(Let b@(NonRec x _) e') +-- = do γ' <- consCBLet γ b +-- consElimE γ' [F.symbol x] e' +-- +-- consE γ (Case e x _ [(ac, ys, ce)]) +-- = do γ' <- consCBLet γ (NonRec x e) +-- γ'' <- caseEnv γ' x [] ac ys +-- consElimE γ'' (F.symbol <$> (x:ys)) ce + +consE γ e@(Let _ _) + = cconsFreshE LetE γ e + +consE γ e@(Case _ _ _ _) + = cconsFreshE CaseE γ e + +consE γ (Tick tt e) + = do t <- consE (γ `setLoc` l) e + addLocA Nothing l (AnnUse t) + return t + where l = tickSrcSpan tt + +consE γ e@(Cast e' _) + = castTy γ (exprType e) e' + +consE γ e@(Coercion _) + = trueTy $ exprType e + +consE _ e + = errorstar $ "consE cannot handle " ++ showPpr e + +castTy _ τ (Var x) + = do t <- trueTy τ + return $ t `strengthen` (uTop $ F.uexprReft $ F.expr x) + +castTy γ τ e + = do t <- trueTy (exprType e) + cconsE γ e t + trueTy τ + +singletonReft = uTop . F.symbolReft . F.symbol + +-- | @consElimE@ is used to *synthesize* types by **existential elimination** +-- instead of *checking* via a fresh template. That is, assuming +-- γ |- e1 ~> t1 +-- we have +-- γ |- let x = e1 in e2 ~> Ex x t1 t2 +-- where +-- γ, x:t1 |- e2 ~> t2 +-- instead of the earlier case where we generate a fresh template `t` and check +-- γ, x:t1 |- e <~ t + +consElimE γ xs e + = do t <- consE γ e + xts <- forM xs $ \x -> (x,) <$> (γ ??= x) + return $ rEx xts t + +-- | @consFreshE@ is used to *synthesize* types with a **fresh template** when +-- the above existential elimination is not easy (e.g. at joins, recursive binders) + +cconsFreshE kvkind γ e + = do t <- freshTy_type kvkind e $ exprType e + addW $ WfC γ t + cconsE γ e t + return t + +checkUnbound γ e x t + | x `notElem` (F.syms t) = t + | otherwise = errorstar $ "consE: cannot handle App " ++ showPpr e ++ " at " ++ showPpr (loc γ) + +dropExists γ (REx x tx t) = liftM (, t) $ (γ, "dropExists") += (x, tx) +dropExists γ t = return (γ, t) + +------------------------------------------------------------------------------------- +cconsCase :: CGEnv -> Var -> SpecType -> [AltCon] -> (AltCon, [Var], CoreExpr) -> CG () +------------------------------------------------------------------------------------- +cconsCase γ x t acs (ac, ys, ce) + = do cγ <- caseEnv γ x acs ac ys + cconsE cγ ce t + +refreshTy t = refreshVV t >>= refreshArgs + +refreshVV (RAllT a t) = liftM (RAllT a) (refreshVV t) +refreshVV (RAllP p t) = liftM (RAllP p) (refreshVV t) +refreshVV (RCls c ts) = liftM (RCls c) (mapM refreshVV ts) + +refreshVV (REx x t1 t2) + = do [t1', t2'] <- mapM refreshVV [t1, t2] + liftM (shiftVV (REx x t1' t2')) fresh + +refreshVV (RFun x t1 t2 r) + = do [t1', t2'] <- mapM refreshVV [t1, t2] + liftM (shiftVV (RFun x t1' t2' r)) fresh + +refreshVV (RAppTy t1 t2 r) + = do [t1', t2'] <- mapM refreshVV [t1, t2] + liftM (shiftVV (RAppTy t1' t2' r)) fresh + +refreshVV (RApp c ts rs r) + = do ts' <- mapM refreshVV ts + rs' <- mapM refreshVVRef rs + liftM (shiftVV (RApp c ts' rs' r)) fresh + +refreshVV t + = return t + + +refreshVVRef (RProp ss t) + = do xs <- mapM (\_ -> fresh) (fst <$> ss) + let su = F.mkSubst $ zip (fst <$> ss) (F.EVar <$> xs) + liftM (RProp (zip xs (snd <$> ss)) . F.subst su) (refreshVV t) +refreshVVRef (RPropP ss r) + = return $ RPropP ss r + + + +------------------------------------------------------------------------------------- +caseEnv :: CGEnv -> Var -> [AltCon] -> AltCon -> [Var] -> CG CGEnv +------------------------------------------------------------------------------------- +caseEnv γ x _ (DataAlt c) ys + = do let (x' : ys') = F.symbol <$> (x:ys) + xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x' + tdc <- γ ??= (dataConSymbol c) >>= refreshVV + let (rtd, yts, _) = unfoldR c tdc (shiftVV xt0 x') ys + let r1 = dataConReft c ys' + let r2 = dataConMsReft rtd ys' + let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2)) + let cbs = safeZip "cconsCase" (x':ys') (xt0:yts) + cγ' <- addBinders γ x' cbs + cγ <- addBinders cγ' x' [(x', xt)] + return cγ + +caseEnv γ x acs a _ + = do let x' = F.symbol x + xt' <- (`strengthen` uTop (altReft γ acs a)) <$> (γ ??= x') + cγ <- addBinders γ x' [(x', xt')] + return cγ + +-- cconsCase γ x t _ (DataAlt c, ys, ce) +-- = do xt0 <- checkTyCon ("checkTycon cconsCase", x) <$> γ ??= x' +-- tdc <- γ ??= (dataConSymbol c) +-- let (rtd, yts, _) = unfoldR c tdc (shiftVV xt0 x') ys +-- let r1 = dataConReft c ys' +-- let r2 = dataConMsReft rtd ys' +-- let xt = xt0 `strengthen` (uTop (r1 `F.meet` r2)) +-- let cbs = safeZip "cconsCase" (x':ys') (xt0:yts) +-- cγ' <- addBinders γ x' cbs +-- cγ <- addBinders cγ' x' [(x', xt)] +-- cconsE cγ ce t +-- where +-- (x':ys') = F.symbol <$> (x:ys) +-- +-- +-- cconsCase γ x t acs (a, _, ce) +-- cconsE cγ ce t + +altReft γ _ (LitAlt l) = literalFReft (emb γ) l +altReft γ acs DEFAULT = mconcat [notLiteralReft l | LitAlt l <- acs] + where notLiteralReft = maybe mempty F.notExprReft . snd . literalConst (emb γ) +altReft _ _ _ = error "Constraint : altReft" + +unfoldR dc td (RApp _ ts rs _) ys = (t3, tvys ++ yts, ignoreOblig rt) + where + tbody = instantiatePvs (instantiateTys td ts) $ reverse rs + (ys0, yts', rt) = safeBkArrow $ instantiateTys tbody tvs' + yts'' = zipWith F.subst sus (yts'++[rt]) + (t3,yts) = (last yts'', init yts'') + sus = F.mkSubst <$> (L.inits [(x, F.EVar y) | (x, y) <- zip ys0 ys']) + (αs, ys') = mapSnd (F.symbol <$>) $ L.partition isTyVar ys + tvs' = rVar <$> αs + tvys = ofType . varType <$> αs + +unfoldR _ _ _ _ = error "Constraint.hs : unfoldR" + +instantiateTys = foldl' go + where go (RAllT α tbody) t = subsTyVar_meet' (α, t) tbody + go _ _ = errorstar "Constraint.instanctiateTy" + +instantiatePvs = foldl' go + where go (RAllP p tbody) r = replacePreds "instantiatePv" tbody [(p, r)] + go _ _ = errorstar "Constraint.instanctiatePv" + +instance Show CoreExpr where + show = showPpr + +checkTyCon _ t@(RApp _ _ _ _) = t +checkTyCon _ t@(RCls cl ts) = classToRApp t +checkTyCon x t = checkErr x t --errorstar $ showPpr x ++ "type: " ++ showPpr t + +-- checkRPred _ t@(RAll _ _) = t +-- checkRPred x t = checkErr x t + +checkFun _ t@(RFun _ _ _ _) = t +checkFun x t = checkErr x t + +checkAll _ t@(RAllT _ _) = t +checkAll x t = checkErr x t + +checkErr (msg, e) t = errorstar $ msg ++ showPpr e ++ ", type: " ++ showpp t + +varAnn γ x t + | x `S.member` recs γ + = AnnLoc (getSrcSpan' x) + | otherwise + = AnnUse t + +getSrcSpan' x + | loc == noSrcSpan + = loc + | otherwise + = loc + where loc = getSrcSpan x + +----------------------------------------------------------------------- +-- | Helpers: Creating Fresh Refinement ------------------------------- +----------------------------------------------------------------------- + +freshPredRef :: CGEnv -> CoreExpr -> PVar RSort -> CG SpecProp +freshPredRef γ e (PV n (PVProp τ) _ as) + = do t <- freshTy_type PredInstE e (toType τ) + args <- mapM (\_ -> fresh) as + let targs = [(x, s) | (x, (s, y, z)) <- zip args as, (F.EVar y) == z ] + γ' <- foldM (++=) γ [("freshPredRef", x, ofRSort τ) | (x, τ) <- targs] + addW $ WfC γ' t + return $ RProp targs t + +freshPredRef _ _ (PV _ PVHProp _ _) + = errorstar "TODO:EFFECTS:freshPredRef" + +----------------------------------------------------------------------- +---------- Helpers: Creating Refinement Types For Various Things ------ +----------------------------------------------------------------------- + +argExpr :: CGEnv -> CoreExpr -> Maybe F.Expr +argExpr _ (Var vy) = Just $ F.eVar vy +argExpr γ (Lit c) = snd $ literalConst (emb γ) c +argExpr γ (Tick _ e) = argExpr γ e +argExpr _ e = errorstar $ "argExpr: " ++ showPpr e + + +varRefType γ x = liftM (varRefType' γ x) (γ ??= F.symbol x) + +varRefType' γ x t' + | Just tys <- trec γ, Just tr <- M.lookup x' tys + = tr `strengthen` xr + | otherwise + = t + where t = t' `strengthen` xr + xr = singletonReft x -- uTop $ F.symbolReft $ F.symbol x + x' = F.symbol x + +-- TODO: should only expose/use subt. Not subsTyVar_meet +subsTyVar_meet' (α, t) = subsTyVar_meet (α, toRSort t, t) + +----------------------------------------------------------------------- +--------------- Forcing Strictness ------------------------------------ +----------------------------------------------------------------------- + +instance NFData CGEnv where + rnf (CGE x1 x2 x3 x5 x6 x7 x8 x9 _ _ x10 x11 _ _ _) + = x1 `seq` rnf x2 `seq` seq x3 `seq` rnf x5 `seq` + rnf x6 `seq` x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 + +instance NFData FEnv where + rnf (FE x1 _) = rnf x1 + +instance NFData SubC where + rnf (SubC x1 x2 x3) + = rnf x1 `seq` rnf x2 `seq` rnf x3 + rnf (SubR x1 _ x2) + = rnf x1 `seq` rnf x2 + +instance NFData Class where + rnf _ = () + +instance NFData RTyCon where + rnf _ = () + +instance NFData Type where + rnf _ = () + +instance NFData WfC where + rnf (WfC x1 x2) + = rnf x1 `seq` rnf x2 + +instance NFData CGInfo where + rnf x = ({-# SCC "CGIrnf1" #-} rnf (hsCs x)) `seq` + ({-# SCC "CGIrnf2" #-} rnf (hsWfs x)) `seq` + ({-# SCC "CGIrnf3" #-} rnf (fixCs x)) `seq` + ({-# SCC "CGIrnf4" #-} rnf (fixWfs x)) `seq` + ({-# SCC "CGIrnf5" #-} rnf (globals x)) `seq` + ({-# SCC "CGIrnf6" #-} rnf (freshIndex x)) `seq` + ({-# SCC "CGIrnf7" #-} rnf (binds x)) `seq` + ({-# SCC "CGIrnf8" #-} rnf (annotMap x)) `seq` + ({-# SCC "CGIrnf9" #-} rnf (specQuals x)) `seq` + ({-# SCC "CGIrnf10" #-} rnf (kuts x)) `seq` + ({-# SCC "CGIrnf10" #-} rnf (lits x)) `seq` + ({-# SCC "CGIrnf10" #-} rnf (kvProf x)) + +------------------------------------------------------------------------------- +--------------------- Reftypes from F.Fixpoint Expressions ---------------------- +------------------------------------------------------------------------------- + +forallExprRefType :: CGEnv -> SpecType -> SpecType +forallExprRefType γ t = t `strengthen` (uTop r') + where r' = fromMaybe mempty $ forallExprReft γ r + r = F.sr_reft $ rTypeSortedReft (emb γ) t + +forallExprReft γ r + = do e <- F.isSingletonReft r + r' <- forallExprReft_ γ e + return r' + +forallExprReft_ γ e@(F.EApp f es) + = case forallExprReftLookup γ (val f) of + Just (xs,_,t) -> let su = F.mkSubst $ safeZip "fExprRefType" xs es in + Just $ F.subst su $ F.sr_reft $ rTypeSortedReft (emb γ) t + Nothing -> Nothing -- F.exprReft e + +forallExprReft_ γ e@(F.EVar x) + = case forallExprReftLookup γ x of + Just (_,_,t) -> Just $ F.sr_reft $ rTypeSortedReft (emb γ) t + Nothing -> Nothing -- F.exprReft e + +forallExprReft_ _ e = Nothing -- F.exprReft e + +forallExprReftLookup γ x = snap <$> F.lookupSEnv x (syenv γ) + where + snap = mapThd3 ignoreOblig . bkArrow . fourth4 . bkUniv . (γ ?=) . F.symbol + +grapBindsWithType tx γ + = fst <$> toListREnv (filterREnv ((== toRSort tx) . toRSort) (renv γ)) + +splitExistsCases z xs tx + = fmap $ fmap (exrefAddEq z xs tx) + +exrefAddEq z xs t (F.Reft(s, rs)) + = F.Reft(s, [F.RConc (F.POr [ pand x | x <- xs])]) + where tref = fromMaybe mempty $ stripRTypeBase t + pand x = F.PAnd $ (substzx x) (fFromRConc <$> rs) + ++ exrefToPred x tref + substzx x = F.subst (F.mkSubst [(z, F.EVar x)]) + +exrefToPred x uref + = F.subst (F.mkSubst [(v, F.EVar x)]) ((fFromRConc <$> r)) + where (F.Reft(v, r)) = ur_reft uref +fFromRConc (F.RConc p) = p +fFromRConc _ = errorstar "can not hanlde existential type with kvars" + +------------------------------------------------------------------------------- +-------------------- Cleaner Signatures For Rec-bindings ---------------------- +------------------------------------------------------------------------------- + +exprLoc :: CoreExpr -> Maybe SrcSpan + +exprLoc (Tick tt _) = Just $ tickSrcSpan tt +exprLoc (App e a) | isType a = exprLoc e +exprLoc _ = Nothing + +isType (Type _) = True +isType a = eqType (exprType a) predType + + +exprRefType :: CoreExpr -> SpecType +exprRefType = exprRefType_ M.empty + +exprRefType_ :: M.HashMap Var SpecType -> CoreExpr -> SpecType +exprRefType_ γ (Let b e) + = exprRefType_ (bindRefType_ γ b) e + +exprRefType_ γ (Lam α e) | isTyVar α + = RAllT (rTyVar α) (exprRefType_ γ e) + +exprRefType_ γ (Lam x e) + = rFun (F.symbol x) (ofType $ varType x) (exprRefType_ γ e) + +exprRefType_ γ (Tick _ e) + = exprRefType_ γ e + +exprRefType_ γ (Var x) + = M.lookupDefault (ofType $ varType x) x γ + +exprRefType_ _ e + = ofType $ exprType e + +bindRefType_ γ (Rec xes) + = extendγ γ [(x, exprRefType_ γ e) | (x,e) <- xes] + +bindRefType_ γ (NonRec x e) + = extendγ γ [(x, exprRefType_ γ e)] + +extendγ γ xts + = foldr (\(x,t) m -> M.insert x t m) γ xts + + + +------------------------------------------------------------------- +-- | Strengthening Binders with TyCon Invariants ------------------ +------------------------------------------------------------------- + +type RTyConInv = M.HashMap RTyCon [SpecType] +type RTyConIAl = M.HashMap RTyCon [SpecType] + +-- mkRTyConInv :: [Located SpecType] -> RTyConInv +mkRTyConInv ts = group [ (c, t) | t@(RApp c _ _ _) <- strip <$> ts] + where + strip = fourth4 . bkUniv . val + +mkRTyConIAl = mkRTyConInv . fmap snd + +addRTyConInv :: RTyConInv -> SpecType -> SpecType +addRTyConInv m t@(RApp c _ _ _) + = case M.lookup c m of + Nothing -> t + Just ts -> foldl' conjoinInvariant' t ts +addRTyConInv _ t + = t + +addRInv :: RTyConInv -> (Var, SpecType) -> (Var, SpecType) +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, t) + where + ids = [id | tc <- M.keys m + , dc <- TC.tyConDataCons $ rtc_tc tc + , id <- DC.dataConImplicitIds dc] + res = ty_res . toRTypeRep + xs = ty_args $ toRTypeRep t + +conjoinInvariant' t1 t2 + = conjoinInvariantShift t1 t2 + +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) + = RApp c (zipWith conjoinInvariantShift ts its) rs (r `F.meet` ir) + +conjoinInvariant t@(RApp _ _ _ r) (RVar _ ir) + = t { rt_reft = r `F.meet` ir } + +conjoinInvariant t@(RVar _ r) (RVar _ ir) + = t { rt_reft = r `F.meet` ir } + +conjoinInvariant t _ + = t + +--------------------------------------------------------------- +----- Refinement Type Environments ---------------------------- +--------------------------------------------------------------- + +instance NFData REnv where + rnf (REnv _) = () -- rnf m + +toListREnv (REnv env) = M.toList env +filterREnv f (REnv env) = REnv $ M.filter f env +fromListREnv = REnv . M.fromList +deleteREnv x (REnv env) = REnv (M.delete x env) +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 +-- domREnv (REnv env) = M.keys env +-- emptyREnv = REnv M.empty + +cgInfoFInfoBot cgi = cgInfoFInfo cgi { specQuals = [] } + +cgInfoFInfoKvars cgi kvars = cgInfoFInfo cgi{fixCs = fixCs' ++ trueCs} + where + fixCs' = concatMap (updateCs kvars) (fixCs cgi) + trueCs = concatMap (`F.trueSubCKvar` (Ci noSrcSpan Nothing)) kvars + +cgInfoFInfo cgi + = F.FI { F.cm = M.fromList $ F.addIds $ fixCs cgi + , F.ws = fixWfs cgi + , F.bs = binds cgi + , F.gs = globals cgi + , F.lits = lits cgi + , F.kuts = kuts cgi + , F.quals = specQuals cgi + } + +updateCs kvars cs + | null lhskvars || F.isFalse rhs + = [cs] + | all (`elem` kvars) lhskvars && null lhsconcs + = [] + | any (`elem` kvars) lhskvars + = [F.removeLhsKvars cs kvars] + | otherwise + = [cs] + where lhskvars = F.reftKVars lhs + rhskvars = F.reftKVars rhs + lhs = F.lhsCs cs + rhs = F.rhsCs cs + F.Reft(_, lhspds) = lhs + lhsconcs = [p | F.RConc p <- lhspds] + +newtype HEnv = HEnv (S.HashSet F.Symbol) + +fromListHEnv = HEnv . S.fromList +elemHEnv x (HEnv s) = x `S.member` s diff --git a/src/Language/Haskell/Liquid/Desugar/Check.lhs b/src/Language/Haskell/Liquid/Desugar/Check.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/Check.lhs @@ -0,0 +1,765 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998 +% +% Author: Juan J. Quintela + +\begin{code} +module Language.Haskell.Liquid.Desugar.Check ( check , ExhaustivePat ) where + +-- #include "HsVersions.h" + +import HsSyn +import TcHsSyn +import Language.Haskell.Liquid.Desugar.DsUtils +import Language.Haskell.Liquid.Desugar.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 +\end{code} + +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} + +\begin{code} +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) +\end{code} + +The function @untidy@ does the reverse work of the @tidy_pat@ funcion. + +\begin{code} + +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 [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) } + | fld <- flds ] dd) + +pars :: NeedPars -> WarningPat -> Pat Name +pars True p = ParPat p +pars _ p = unLoc p + +untidy_lit :: HsLit -> HsLit +untidy_lit (HsCharPrim c) = HsChar c +untidy_lit lit = lit +\end{code} + +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} + + +\begin{code} + +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 nlWildPat),[])], 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 +\end{code} + +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. + +\begin{code} +split_by_literals :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat], EqnSet) +split_by_literals qs = process_literals used_lits qs + where + used_lits = get_used_lits qs +\end{code} + +@process_explicit_literals@ is a function that process each literal that appears +in the column of the matrix. + +\begin{code} +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 +\end{code} + + +@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. + +\begin{code} + +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 = [(nlWildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats + indexs_default = unionUniqSets indexs' indexs +\end{code} + +Here we have selected the literal and we will select all the equations that +begins for that literal and create a new matrix. + +\begin{code} +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" +\end{code} + +This function splits the equations @qs@ in groups that deal with the +same constructor. + +\begin{code} +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 +\end{code} + +The first column of the patterns matrix only have vars, then there is +nothing to do. + +\begin{code} +first_column_only_vars :: [(EqnNo, EquationInfo)] -> ([ExhaustivePat],EqnSet) +first_column_only_vars qs = (map (\ (xs,ys) -> (nlWildPat:xs,ys)) pats,indexs) + where + (pats, indexs) = check' (map remove_var qs) +\end{code} + +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. + +\begin{code} +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)) +\end{code} + +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} + +\begin{code} +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 nlWildPat),[(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 nlWildPat) + +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) | or (map (\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 (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i)) +get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) +get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim (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 +\end{code} + +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{\ ???\ } +% +\begin{code} +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, pat_arg_tys = tys }) (ps, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc) tys) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) + | otherwise = (nlConPat 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 nlWildPat nlWildPat + | otherwise = nlConPat name pats + where + name = getName con + pats = [nlWildPat | _ <- dataConOrigArgTys con] +\end{code} + +------------------------------------------------------------------------ + 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. + +\begin{code} +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 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 s <- lit + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat 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 nlWildPat) + -- 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, nlWildPat)) (dataConFieldLabels dc) + PatSynCon{} -> panic "Check.tidy_con: pattern synonym with record syntax" + all_pats = foldr (\(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 +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/Coverage.lhs b/src/Language/Haskell/Liquid/Desugar/Coverage.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/Coverage.lhs @@ -0,0 +1,1240 @@ +% +% (c) Galois, 2006 +% (c) University of Glasgow, 2007 +% +\begin{code} +module Language.Haskell.Liquid.Desugar.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 Unique +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 +\end{code} + + +%************************************************************************ +%* * +%* The main function: addTicksToBinds +%* * +%************************************************************************ + +\begin{code} +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 = + + case ml_hs_file mod_loc of + Nothing -> return (binds, emptyHpcInfo False, emptyModBreaks) + Just orig_file -> do + + if "boot" `isSuffixOf` orig_file + then return (binds, emptyHpcInfo False, emptyModBreaks) + else do + + let orig_file2 = guessSourceFile binds orig_file + + (binds1,_,st) + = unTM (addTickLHsBinds binds) + (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 dflags + , this_mod = mod + , tickishType = case hscTarget dflags of + HscInterpreted -> Breakpoints + _ | gopt Opt_Hpc dflags -> HpcTicks + | gopt Opt_SccProfilingOn dflags + -> ProfNotes + | otherwise -> error "addTicksToBinds: No way to annotate!" + }) + (TT + { tickBoxCount = 0 + , mixEntries = [] + }) + + let entries = reverse $ mixEntries st + + let count = tickBoxCount st + hashNo <- writeMixEntries dflags mod count entries orig_file2 + modBreaks <- mkModBreaks dflags count entries + + when (dopt Opt_D_dump_ticked dflags) $ + log_action dflags dflags SevDump noSrcSpan defaultDumpStyle + (pprLHsBinds binds1) + + return (binds1, HpcInfo count hashNo, modBreaks) + + +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 + | modulePackageId mod == mainPackageId = hpc_dir + | otherwise = hpc_dir ++ "/" ++ packageIdString (modulePackageId 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 :: DynFlags -> TickDensity +mkDensity dflags + | gopt Opt_Hpc dflags = TickForCoverage + | HscInterpreted <- hscTarget dflags = TickForBreakPoints + | ProfAutoAll <- profAuto dflags = TickAllFunctions + | ProfAutoTop <- profAuto dflags = TickTopFunctions + | ProfAutoExports <- profAuto dflags = TickExportedFunctions + | ProfAutoCalls <- profAuto dflags = TickCallSites + | otherwise = panic "desnity" + -- ToDo: -fhpc is taking priority over -fprof-auto here. It seems + -- that coverage works perfectly well with profiling, but you don't + -- get any auto-generated SCCs. It would make perfect sense to + -- allow both of them, and indeed to combine some of the other flags + -- (-fprof-auto-calls -fprof-auto-top, for example) + +-- | 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 `addListToNameSet` + [ 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 + env <- getEnv + let dflags = tte_dflags env + 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] + if inline && gopt Opt_SccProfilingOn dflags 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 + + return $ L pos $ funBind { fun_matches = mg { mg_alts = matches' } + , fun_tick = tick } + + 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 + + density <- getDensity + decl_path <- getPathEntry + let top_lev = null decl_path + let add_ticks = shouldTickPatBind density top_lev + + tickish <- if add_ticks + then bindTick density name pos fvs + else return Nothing + + let patvars = map getOccString (collectPatBinders lhs) + patvar_ticks <- if add_ticks + then mapM (\v -> bindTick density v pos fvs) patvars + else return [] + + return $ L pos $ pat { pat_rhs = rhs', + pat_ticks = (tickish, patvar_ticks)} + +-- 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 (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') +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 nm e) = + liftM2 HsSCC + (return nm) + (addTickLHsExpr e) +addTickHsExpr (HsCoreAnn nm e) = + liftM2 HsCoreAnn + (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 :: HsTupArg Id -> TM (HsTupArg Id) +addTickTupArg (Present e) = do { e' <- addTickLHsExpr e; return (Present e') } +addTickTupArg (Missing ty) = return (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 pats opSig gRHSs) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs + return $ Match 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 pats opSig gRHSs) = + bindLocals (collectPatsBinders pats) $ do + gRHSs' <- addTickCmdGRHSs gRHSs + return $ Match 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 (HsRecField ids expr doc) + = do { expr' <- addTickLHsExpr expr + ; return (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' +\end{code} + +\begin{code} +data TickTransState = TT { tickBoxCount:: Int + , mixEntries :: [MixEntry_] + } + +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 + + +-- | 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) + +-- getState :: TM TickTransState +-- getState = TM $ \ env st -> (st, noFVs, st) + +-- setState :: (TickTransState -> TickTransState) -> TM () +-- setState f = TM $ \ env 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 = + TM $ \ env st -> + let c = tickBoxCount st + 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. + + mes = mixEntries st + me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel) + + cc_name | topOnly = head decl_path + | otherwise = concat (intersperse "." decl_path) + + cc = mkUserCC (mkFastString cc_name) (this_mod env) pos (mkCostCentreUnique c) + + dflags = tte_dflags env + + count = countEntries && gopt Opt_ProfCountEntries dflags + + tickish = case tickishType env of + HpcTicks -> HpcTick (this_mod env) c + ProfNotes -> ProfNote cc count True{-scopes-} + Breakpoints -> Breakpoint c ids + in + ( tickish + , fvs + , st {tickBoxCount=c+1,mixEntries=me:mes} + ) + + +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") +\end{code} + + +\begin{code} +matchesOneOfMany :: [LMatch Id body] -> Bool +matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1 + where + matchCount (L _ (Match _pats _ty (GRHSs grhss _binds))) = length grhss +\end{code} + + +\begin{code} +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) +\end{code} + +%************************************************************************ +%* * +%* 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);} + +\begin{code} +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = 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 (packageIdFS (modulePackageId this_mod))) + full_name_str + | modulePackageId this_mod == mainPackageId + = module_name + | otherwise + = package_name <> char '/' <> module_name +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/Desugar.lhs b/src/Language/Haskell/Liquid/Desugar/Desugar.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/Desugar.lhs @@ -0,0 +1,440 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +The Desugarer: turning HsSyn into Core. + +\begin{code} +module Language.Haskell.Liquid.Desugar.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 InstEnv +import Class +import Avail +import PatSyn +import CoreSyn +import CoreSubst +import PprCore +import DsMonad +import Language.Haskell.Liquid.Desugar.DsExpr +import Language.Haskell.Liquid.Desugar.DsBinds +import Language.Haskell.Liquid.Desugar.DsForeign +import Module +import NameSet +import NameEnv +import Rules +import BasicTypes ( Activation(.. ) ) +import CoreMonad ( endPass, CoreToDo(..) ) +import FastString +import ErrUtils +import Outputable +import SrcLoc +import Coverage +import Util +import MonadUtils +import OrdList +import Data.List +import Data.IORef +import Control.Monad( when ) +\end{code} + +%************************************************************************ +%* * +%* The main function: deSugar +%* * +%************************************************************************ + +\begin{code} +-- | 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 + ; showPass dflags "Desugar" + + -- Desugar the program + ; let export_set = availsToNameSet exports + target = hscTarget dflags + hpcInfo = emptyHpcInfo other_hpc_info + want_ticks = gopt Opt_Hpc dflags + || target == HscInterpreted + || (gopt Opt_SccProfilingOn dflags + && case profAuto dflags of + NoProfAuto -> False + _ -> True) + + ; (binds_cvr, ds_hpc_info, modBreaks) + <- if want_ticks && not (isHsBoot 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 + ; let hpc_init + | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info + | otherwise = empty + ; return ( ds_ev_binds + , foreign_prs `appOL` core_prs `appOL` spec_prs + , spec_rules ++ ds_rules, ds_vects + , ds_fords `appendStubC` hpc_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 + + ; endPass hsc_env 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 = isHsBoot hsc_src, + 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 = filter ((`elemNameSet` export_set) . patSynName) 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) +\end{code} + +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. + + +\begin{code} +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) } +\end{code} + +%************************************************************************ +%* * +%* Add rules and export flags to binders +%* * +%************************************************************************ + +\begin{code} +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) +\end{code} + + +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 +%* * +%************************************************************************ + +\begin{code} +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 | RuleBndr (L _ var) <- vars] + + ; lhs' <- unsetGOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] + + ; rhs' <- dsLExpr rhs + ; dflags <- getDynFlags + + -- 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 + 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 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) + } } } +\end{code} + +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 #-} + + +%************************************************************************ +%* * +%* Desugaring vectorisation declarations +%* * +%************************************************************************ + +\begin{code} +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) +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs b/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsArrows.lhs @@ -0,0 +1,1202 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Desugaring arrow commands + +\begin{code} +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + +module Language.Haskell.Liquid.Desugar.DsArrows ( dsProcExpr ) where + +-- #include "HsVersions.h" + +import Language.Haskell.Liquid.Desugar.Match +import Language.Haskell.Liquid.Desugar.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.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) + +import TcType +import TcEvidence +import CoreSyn +import CoreFVs +import CoreUtils +import MkCore +import Language.Haskell.Liquid.Desugar.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 +\end{code} + +\begin{code} +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))) +\end{code} + +Build case analysis of a tuple. This cannot be done in the DsM monad, +because the list of variables is typically not yet defined. + +\begin{code} +-- 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)] +\end{code} + +\begin{code} +mkCorePairTy :: Type -> Type -> Type +mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2] + +mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr +mkCorePairExpr e1 e2 = mkCoreTup [e1, e2] + +mkCoreUnitExpr :: CoreExpr +mkCoreUnitExpr = mkCoreTup [] +\end{code} + +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. + +\begin{code} +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) +\end{code} + +\begin{code} +mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr Id +mkHsEnvStackExpr env_ids stack_id + = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id] +\end{code} + +Translation of arrow abstraction + +\begin{code} + +-- 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) +\end{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 + +\begin{code} +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) +\end{code} + +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 |||. + +\begin{code} +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)) + +\end{code} + +Translation of command judgements of the form + + D |-a do { ss } : t + +\begin{code} + +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) + +\end{code} +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. +\begin{code} +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) + +\end{code} +A sequence of statements (as in a rec) is desugared to an arrow between +two environments (no stack) +\begin{code} + +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 []" +\end{code} + +Match a list of expressions against a list of patterns, left-to-right. + +\begin{code} +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" +\end{code} + +List of leaf expressions, with set of variables bound in each + +\begin{code} +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] +\end{code} + +Replace the leaf commands in a match + +\begin{code} +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 pat mt (GRHSs grhss binds))) + = let + (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss + in + (leaves', L loc (Match 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 []" +\end{code} + +Balanced fold of a non-empty list. + +\begin{code} +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 +\end{code} + +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. + +\begin{code} +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 + +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs b/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsBinds.lhs @@ -0,0 +1,900 @@ +% +% (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). + +\begin{code} +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + +module Language.Haskell.Liquid.Desugar.DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, + dsHsWrapper, dsTcEvBinds, dsEvBinds + ) where + +-- #include "HsVersions.h" + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr( dsLExpr ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match( matchWrapper ) + +import DsMonad +import Language.Haskell.Liquid.Desugar.DsGRHSs +import Language.Haskell.Liquid.Desugar.DsUtils + +import HsSyn -- lots of things +import CoreSyn -- lots of things +import Literal ( Literal(MachStr) ) +import CoreSubst +import MkCore +import CoreUtils +import CoreArity ( etaExpand ) +import CoreUnfold +import CoreFVs +import UniqSupply +import Unique( Unique ) +import Digraph + + +import TyCon ( isTupleTyCon, tyConDataCons_maybe ) +import TcEvidence +import TcType +import Type +import Coercion hiding (substCo) +import TysWiredIn ( eqBoxDataCon, coercibleDataCon, tupleCon ) +import Id +import Class +import DataCon ( dataConWorkId ) +import Name +import MkId ( seqId ) +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) +\end{code} + +%************************************************************************ +%* * +\subsection[dsMonoBinds]{Desugaring a @MonoBinds@} +%* * +%************************************************************************ + +\begin{code} +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) + + | 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) + + +dictArity :: [Var] -> Arity +-- Don't count coercion variables in arity +dictArity dicts = count isId dicts +\end{code} + +[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, hopefullly 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. + +\begin{code} +------------------------ +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) + ; case decomposeRuleLhs bndrs ds_lhs of { + Left msg -> do { warnDs msg; return Nothing } ; + Right (rule_bndrs, _fn, args) -> do + + { dflags <- getDynFlags + ; let spec_unf = specUnfolding bndrs args (realIdUnfolding poly_id) + 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 + ; let spec_pair = makeCorePair dflags spec_id False (dictArity bndrs) spec_rhs + + ; when (isInlinePragma id_inl && wopt Opt_WarnPointlessPragmas dflags) + (warnDs (specOnInline poly_name)) + ; return (Just (unitOL spec_pair, rule)) + } } } + 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 + + +specUnfolding :: [Var] -> [CoreExpr] -> Unfolding -> Unfolding +specUnfolding new_bndrs new_args df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = -- ASSERT2( equalLength new_args bndrs, ppr df $$ ppr new_args $$ ppr new_bndrs ) + df { df_bndrs = new_bndrs, df_args = map (substExpr (text "specUnfolding") subst) args } + where + subst = mkOpenSubst (mkInScopeSet fvs) (bndrs `zip` new_args) + fvs = (exprsFreeVars args `delVarSetList` bndrs) `extendVarSetList` new_bndrs + +specUnfolding _ _ _ = noUnfolding + +specOnInline :: Name -> MsgDoc +specOnInline f = ptext (sLit "SPECIALISE pragma on INLINE function probably won't fire:") + <+> quotes (ppr f) +\end{code} + + +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} +%* * +%************************************************************************ + +\begin{code} +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 [Constant rule dicts]) +-- +-- Returns Nothing if the LHS isn't of the expected shape +decomposeRuleLhs bndrs lhs + = -- Note [Simplifying the left-hand side of a RULE] + case collectArgs opt_lhs of + (Var fn, args) -> check_bndrs fn args + + (Case scrut bndr ty [(DEFAULT, _, body)], args) + | isDeadBinder bndr -- Note [Matching seqId] + -> check_bndrs seqId (args' ++ args) + where + args' = [Type (idType bndr), Type ty, scrut, body] + + _other -> Left bad_shape_msg + where + opt_lhs = simpleOptExpr lhs + + check_bndrs fn args + | null dead_bndrs = Right (extra_dict_bndrs ++ bndrs, fn, args) + | otherwise = Left (vcat (map dead_msg dead_bndrs)) + where + arg_fvs = exprsFreeVars args + + -- Check for dead binders: Note [Unused spec binders] + dead_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs + + -- Add extra dict binders: Note [Constant rule dicts] + extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d) + | d <- varSetElems (arg_fvs `delVarSetList` bndrs) + , isDictId d] + + + bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) + 2 (ppr opt_lhs) + dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr + , ptext (sLit "is not bound in RULE lhs")]) + 2 (ppr opt_lhs) + 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) +\end{code} + +Note [Simplifying the left-hand side of a RULE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +simpleOptExpr occurrence-analyses and simplifies the lhs +and thereby +(a) sorts dict bindings into NonRecs and inlines them +(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) does eta reduction + +For (c) 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) + +NB: tcSimplifyRuleLhs is very careful not to generate complicated + dictionary expressions that we might have to match + +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 [Constant rule dicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 +%* * +%************************************************************************ + + +\begin{code} +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 = dsHsWrapper c1 =<< dsHsWrapper c2 e +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 evtrm) e = liftM (App e) (dsEvTerm evtrm) + +-------------------------------------- +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 + +--------------------------------------- +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) = let leftCo = go co1 + rightRole = nextRole leftCo in + mkAppCoFlexible leftCo rightRole (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 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) + + 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) +\end{code} + +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/Desugar/DsExpr.lhs b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs @@ -0,0 +1,864 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Desugaring exporessions. + +\begin{code} +module Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where + +import Language.Haskell.Liquid.GhcMisc (srcSpanTick) + +import Language.Haskell.Liquid.Desugar.Match +import Language.Haskell.Liquid.Desugar.MatchLit +import Language.Haskell.Liquid.Desugar.DsBinds +import Language.Haskell.Liquid.Desugar.DsGRHSs +import Language.Haskell.Liquid.Desugar.DsListComp +import Language.Haskell.Liquid.Desugar.DsUtils +import Language.Haskell.Liquid.Desugar.DsArrows +import DsMonad +import Name +import NameEnv +import FamInstEnv( topNormaliseType ) + +import HsSyn + +-- 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 BasicTypes +import Maybes +import SrcLoc +import Util +import Bag +import Outputable +import FastString + +import Control.Monad +\end{code} + + +%************************************************************************ +%* * + dsLocalBinds, dsValBinds +%* * +%************************************************************************ + +\begin{code} +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 + +\end{code} + +%************************************************************************ +%* * +\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals} +%* * +%************************************************************************ + +\begin{code} +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" +\end{code} + +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. + +\begin{code} +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) (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) (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 + mod_name <- getModule + count <- goptM Opt_ProfCountEntries + uniq <- newUnique + Tick (ProfNote (mkUserCC cc mod_name loc uniq) count True) <$> 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")) +\end{code} + + +\noindent +\underline{\bf Various data construction things} +% ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +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 +\end{code} + +\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. + +\begin{code} +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:rhss) -> -- 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 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) +\end{code} + +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. + +\begin{code} +dsExpr expr@(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 = Generated }) + + ; return (add_field_binds field_binds' $ + bindNonRec discrim_var record_expr' matching_code) } + where + ds_field :: HsRecField 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 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) } + +\end{code} + +Here is where we desugar the Template Haskell brackets and escapes + +\begin{code} +-- 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 +\end{code} + +Hpc Support + +\begin{code} +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 + } +\end{code} + +\begin{code} + +-- 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 (HsTickPragma {}) = panic "dsExpr:HsTickPragma" +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 :: [HsRecField Id arg] -> Name -> [arg] +findField rbinds lbl + = [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds + , lbl == idName (unLoc id) ] +\end{code} + +%-------------------------------------------------------------------- + +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. + + +\begin{code} +dsExplicitList :: PostTcType -> 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'] +\end{code} + +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in DsListComp). Basically does the translation given in the +Haskell 98 report: + +\begin{code} +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) +\end{code} + + +%************************************************************************ +%* * +\subsection{Errors and contexts} +%* * +%************************************************************************ + +\begin{code} +-- 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 ] +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot @@ -0,0 +1,11 @@ +\begin{code} +module Language.Haskell.Liquid.Desugar.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 +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs b/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsForeign.lhs @@ -0,0 +1,808 @@ +% +% (c) The University of Glasgow 2006 +% (c) The AQUA Project, Glasgow University, 1998 +% + +Desugaring foreign declarations (see also DsCCall). + +\begin{code} +module Language.Haskell.Liquid.Desugar.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 Util +import Hooks + +import Data.Maybe +import Data.List +\end{code} + +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. + +\begin{code} +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 (CExportStatic ext_nm cconv))) = do + (h, c, _, _) <- dsFExport id co ext_nm cconv False + return (h, c, [id], []) +\end{code} + + +%************************************************************************ +%* * +\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. + +\begin{code} +dsFImport :: Id + -> Coercion + -> ForeignImport + -> DsM ([Binding], SDoc, SDoc) +dsFImport id co (CImport cconv safety mHeader spec) = do + (ids, h, c) <- dsCImport id co spec cconv safety mHeader + return (ids, h, c) + +dsCImport :: Id + -> Coercion + -> CImportSpec + -> CCallConv + -> Safety + -> Maybe Header + -> DsM ([Binding], SDoc, SDoc) +dsCImport id co (CLabel cid) cconv _ _ = 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 +\end{code} + + +%************************************************************************ +%* * +\subsection{Foreign calls} +%* * +%************************************************************************ + +\begin{code} +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 mPackageId isFun) CApiConv safety) -> + do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) + let fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId 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) +\end{code} + + +%************************************************************************ +%* * +\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. + +\begin{code} +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) + +\end{code} + +%************************************************************************ +%* * +\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@'. + +\begin{code} +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 +\end{code} + +@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: + +f_helper(StablePtr s, HsBool b, HsInt i) +{ + rts_evalIO(rts_apply(rts_apply(deRefStablePtr(s), + rts_mkBool(b)), rts_mkInt(i))); +} +\end{verbatim} + +\begin{code} +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))) +\end{code} + +%* +% +\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. + +\begin{code} +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 (_, _, data_con, [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" +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs @@ -0,0 +1,161 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Matching guarded right-hand-sides (GRHSs) + +\begin{code} +module Language.Haskell.Liquid.Desugar.DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS ) where + +-- #include "HsVersions.h" + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( matchSinglePat ) + +import HsSyn +import MkCore +import CoreSyn +import Var +import Type + +import DsMonad +import Language.Haskell.Liquid.Desugar.DsUtils +import TysWiredIn +import PrelNames +import Module +import Name +import Util +import SrcLoc +import Outputable +\end{code} + +@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@. + +\begin{code} +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 +\end{code} + +In contrast, @dsGRHSs@ produces a @MatchResult@. + +\begin{code} +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 + (\e -> dsLocalBinds binds e) + 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 +\end{code} + + +%************************************************************************ +%* * +%* matchGuard : make a MatchResult from a guarded RHS * +%* * +%************************************************************************ + +\begin{code} +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 +\end{code} + +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/Desugar/DsListComp.lhs b/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsListComp.lhs @@ -0,0 +1,880 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Desugaring list comprehensions, monad comprehensions and array comprehensions + +\begin{code} +{-# LANGUAGE NamedFieldPuns #-} + +module Language.Haskell.Liquid.Desugar.DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where + +-- #include "HsVersions.h" + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) + +import HsSyn +import TcHsSyn +import CoreSyn +import MkCore + +import DsMonad -- the monadery used in the desugarer +import Language.Haskell.Liquid.Desugar.DsUtils + +import DynFlags +import CoreUtils +import Id +import Type +import TysWiredIn +import Language.Haskell.Liquid.Desugar.Match +import PrelNames +import SrcLoc +import Outputable +import FastString +import TcType +import ListSetOps( getNth ) +import Util +\end{code} + +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. + +\begin{code} +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" +\end{code} + +%************************************************************************ +%* * +\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. + +\begin{code} + +deListComp :: [ExprStmt Id] -> CoreExpr -> DsM CoreExpr + +deListComp [] _ = panic "deListComp" + +deListComp (LastStmt body _ : quals) 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" +\end{code} + + +\begin{code} +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) +\end{code} + +%************************************************************************ +%* * +\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} + +\begin{code} +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 _ : quals) + = -- 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 +\end{code} + +%************************************************************************ +%* * +\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring} +%* * +%************************************************************************ + +\begin{code} + +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 +\end{code} + +%************************************************************************ +%* * +\subsection[DsPArrComp]{Desugaring of array comprehensions} +%* * +%************************************************************************ + +\begin{code} + +-- 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' _ : quals) 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" +\end{code} + +Translation for monad comprehensions + +\begin{code} +-- 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) stmts + = -- 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])) } +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/DsMeta.hs b/src/Language/Haskell/Liquid/Desugar/DsMeta.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsMeta.hs @@ -0,0 +1,2816 @@ +----------------------------------------------------------------------------- +-- +-- (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.Desugar.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.Desugar.DsExpr ( dsExpr ) + +import Language.Haskell.Liquid.Desugar.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 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, Splice (unLoc e)) | (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 + = do { let { tv_bndrs = hsSigTvBinders (hs_valds group) + ; 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 { + fix_ds <- mapM repFixD (hs_fixds group) ; + val_ds <- rep_val_binds (hs_valds group) ; + tycl_ds <- mapM repTyClD (tyClGroupConcat (hs_tyclds group)) ; + role_ds <- mapM repRoleD (concatMap group_roles (hs_tyclds group)) ; + inst_ds <- mapM repInstD (hs_instds group) ; + rule_ds <- mapM repRuleD (hs_ruleds group) ; + for_ds <- mapM repForD (hs_fords group) ; + -- more needed + return (de_loc $ sort_by_loc $ + val_ds ++ catMaybes tycl_ds ++ role_ds ++ fix_ds + ++ inst_ds ++ rule_ds ++ for_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 + } + + +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) + ; repNewtype cxt1 tc bndrs opt_tys con1 derivs1 } + DataType -> do { cons1 <- repList conQTyConName (repC tv_names) cons + ; 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 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 Name)] -> DsM (Core [TH.FunDep]) +repLFunDeps fds = repList funDepTyConName repLFunDep fds + +repLFunDep :: Located (FunDep Name) -> DsM (Core TH.FunDep) +repLFunDep (L _ (xs, ys)) = do xs' <- repList nameTyConName lookupBinder xs + ys' <- repList nameTyConName lookupBinder 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 + +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 (TyFamInstEqn { tfie_pats = HsWB { hswb_cts = tys + , hswb_kvs = kv_names + , hswb_tvs = tv_names } + , tfie_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 cc 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 callConv = notHandled "repCCallConv" (ppr callConv) + +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 name (Fixity prec dir))) + = do { MkC name' <- lookupLOcc name + ; MkC prec' <- coreIntLit prec + ; let rep_fn = case dir of + InfixL -> infixLDName + InfixR -> infixRDName + InfixN -> infixNDName + ; dec <- rep2 rep_fn [prec', name'] + ; return (loc, dec) } + +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 n + ; act' <- repPhases act + ; lhs' <- repLE lhs + ; rhs' <- repLE rhs + ; repPragRule n' bndrs' lhs' rhs' act' } + ; rule2 <- wrapGenSyms ss rule1 + ; return (loc, rule2) } + +ruleBndrNames :: RuleBndr Name -> [Name] +ruleBndrNames (RuleBndr n) = [unLoc n] +ruleBndrNames (RuleBndrSig n (HsWB { hswb_kvs = kvs, hswb_tvs = tvs })) + = unLoc n : kvs ++ tvs + +repRuleBndr :: RuleBndr Name -> DsM (Core TH.RuleBndrQ) +repRuleBndr (RuleBndr n) + = do { MkC n' <- lookupLBinder n + ; rep2 ruleVarName [n'] } +repRuleBndr (RuleBndrSig n (HsWB { hswb_cts = ty })) + = do { MkC n' <- lookupLBinder n + ; MkC ty' <- repLTy ty + ; rep2 typedRuleVarName [n', ty'] } + +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_name = con, con_qvars = con_tvs, con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) + | null (hsQTvBndrs con_tvs) + = do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] + ; repConstr con1 details } + +repC tvs (L _ (ConDecl { con_name = con + , 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 + ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs + do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] + ; c' <- repConstr con1 details + ; ctxt' <- repContext (eq_ctxt ++ ctxt) + ; rep2 forallCName [unC ex_bndrs, unC ctxt', unC c'] } } + +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 (HsUserBang (Just True) True) ty) -> (unpackedName, ty) + L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty) + _ -> (notStrictName, ty) + +------------------------------------------------------- +-- Deriving clause +------------------------------------------------------- + +repDerivs :: Maybe [LHsType Name] -> DsM (Core [TH.Name]) +repDerivs Nothing = coreList nameTyConName [] +repDerivs (Just 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)] + -- Singleton => Ok + -- Empty => Too hard, signature ignored +rep_sig (L loc (TypeSig nms ty)) = mapM (rep_ty_sig loc ty) nms +rep_sig (L _ (GenericSig nm _)) = failWithDs msg + where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) + , ptext (sLit "Default signatures are not supported by Template Haskell") ] + +rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc +rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc +rep_sig (L loc (SpecInstSig ty)) = rep_specialiseInst ty loc +rep_sig _ = return [] + +rep_ty_sig :: SrcSpan -> LHsType Name -> Located Name + -> DsM (SrcSpan, Core TH.DecQ) +rep_ty_sig loc (L _ ty) nm + = do { nm1 <- lookupLOcc nm + ; ty1 <- rep_ty ty + ; sig <- repProto 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 predQTyConName repLPred ctxt + repCtxt preds + +-- represent a type predicate +-- +repLPred :: LHsType Name -> DsM (Core TH.PredQ) +repLPred (L _ p) = repPred p + +repPred :: HsType Name -> DsM (Core TH.PredQ) +repPred (HsParTy ty) + = repLPred ty +repPred ty + | Just (cls, tys) <- splitHsClassTy_maybe ty + = do + cls1 <- lookupOcc cls + tys1 <- repList typeQTyConName repLTy tys + repClassP cls1 tys1 +repPred (HsEqTy tyleft tyright) + = do + tyleft1 <- repLTy tyleft + tyright1 <- repLTy tyright + repEqualP tyleft1 tyright1 +repPred ty + = notHandled "Exotic predicate type" (ppr ty) + +-- 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 (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 (Splice 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 (Bound y) -> repVarOrCon x (coreVar y) + Just (Splice 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 | Present e <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | 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 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 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 fld = do { MkC v <- lookupLOcc (hsRecFieldId fld) + ; MkC p <- repLP (hsRecFieldArg fld) + ; rep2 fieldPatName [v,p] } + +repP (NPat 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,Bound 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 (Bound x) -> return (coreVar x) + Just (Splice _) -> 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 = packageIdString (modulePackageId 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] + +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] + +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 :: Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ) +repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] + +repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) +repCtxt (MkC tys) = rep2 cxtName [tys] + +repClassP :: Core TH.Name -> Core [TH.TypeQ] -> DsM (Core TH.PredQ) +repClassP (MkC cla) (MkC tys) = rep2 classPName [cla, tys] + +repEqualP :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.PredQ) +repEqualP (MkC ty1) (MkC ty2) = rep2 equalPName [ty1, ty2] + +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 ips) + = do { arg_vtys <- repList varStrictTypeQTyConName rep_ip ips + ; rep2 recCName [unC con, unC arg_vtys] } + where + rep_ip ip = do { MkC v <- lookupLOcc (cd_fld_name ip) + ; MkC ty <- repBangTy (cd_fld_type ip) + ; 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] + +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 ----------------------- +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, + -- FieldExp + fieldExpName, + -- Body + guardedBName, normalBName, + -- Guard + normalGEName, patGEName, + -- Stmt + bindSName, letSName, noBindSName, parSName, + -- Dec + funDName, valDName, dataDName, newtypeDName, tySynDName, + classDName, instanceDName, sigDName, forImpDName, + pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName, + pragRuleDName, + familyNoKindDName, familyKindDName, dataInstDName, newtypeInstDName, + tySynInstDName, closedTypeFamilyKindDName, closedTypeFamilyNoKindDName, + infixLDName, infixRDName, infixNDName, + roleAnnotDName, + -- Cxt + cxtName, + -- Pred + classPName, equalPName, + -- Strict + isStrictName, notStrictName, unpackedName, + -- Con + normalCName, recCName, infixCName, forallCName, + -- StrictType + strictTypeName, + -- VarStrictType + varStrictTypeName, + -- Type + forallTName, varTName, conTName, appTName, + 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, + -- 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, + + -- 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 thPackageId (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 :: 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 + +-- 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, familyNoKindDName, + 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 +sigDName = libFun (fsLit "sigD") sigDIdKey +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 +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 Pred = ... +classPName, equalPName :: Name +classPName = libFun (fsLit "classP") classPIdKey +equalPName = libFun (fsLit "equalP") equalPIdKey + +-- 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, 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 +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 :: Name +cCallName = libFun (fsLit "cCall") cCallIdKey +stdCallName = libFun (fsLit "stdCall") stdCallIdKey + +-- 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 + +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 :: 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 + +-- 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, + familyNoKindDIdKey, familyKindDIdKey, + dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey, + 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 417 +pragRuleDIdKey = mkPreludeMiscIdUnique 418 +familyNoKindDIdKey = mkPreludeMiscIdUnique 342 +familyKindDIdKey = mkPreludeMiscIdUnique 343 +dataInstDIdKey = mkPreludeMiscIdUnique 344 +newtypeInstDIdKey = mkPreludeMiscIdUnique 345 +tySynInstDIdKey = mkPreludeMiscIdUnique 346 +closedTypeFamilyKindDIdKey = mkPreludeMiscIdUnique 347 +closedTypeFamilyNoKindDIdKey = mkPreludeMiscIdUnique 348 +infixLDIdKey = mkPreludeMiscIdUnique 349 +infixRDIdKey = mkPreludeMiscIdUnique 350 +infixNDIdKey = mkPreludeMiscIdUnique 351 +roleAnnotDIdKey = mkPreludeMiscIdUnique 352 + +-- type Cxt = ... +cxtIdKey :: Unique +cxtIdKey = mkPreludeMiscIdUnique 360 + +-- data Pred = ... +classPIdKey, equalPIdKey :: Unique +classPIdKey = mkPreludeMiscIdUnique 361 +equalPIdKey = mkPreludeMiscIdUnique 362 + +-- 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, 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 +litTIdKey = mkPreludeMiscIdUnique 389 +promotedTIdKey = mkPreludeMiscIdUnique 390 +promotedTupleTIdKey = mkPreludeMiscIdUnique 391 +promotedNilTIdKey = mkPreludeMiscIdUnique 392 +promotedConsTIdKey = mkPreludeMiscIdUnique 393 + +-- data TyLit = ... +numTyLitIdKey, strTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 394 +strTyLitIdKey = mkPreludeMiscIdUnique 395 + +-- data TyVarBndr = ... +plainTVIdKey, kindedTVIdKey :: Unique +plainTVIdKey = mkPreludeMiscIdUnique 396 +kindedTVIdKey = mkPreludeMiscIdUnique 397 + +-- 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 :: Unique +cCallIdKey = mkPreludeMiscIdUnique 412 +stdCallIdKey = mkPreludeMiscIdUnique 413 + +-- data Safety = ... +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 414 +safeIdKey = mkPreludeMiscIdUnique 415 +interruptibleIdKey = mkPreludeMiscIdUnique 416 + +-- 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 419 + +-- data FamFlavour = ... +typeFamIdKey, dataFamIdKey :: Unique +typeFamIdKey = mkPreludeMiscIdUnique 420 +dataFamIdKey = mkPreludeMiscIdUnique 421 + +-- data TySynEqn = ... +tySynEqnIdKey :: Unique +tySynEqnIdKey = mkPreludeMiscIdUnique 422 + +-- quasiquoting +quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique +quoteExpKey = mkPreludeMiscIdUnique 423 +quotePatKey = mkPreludeMiscIdUnique 424 +quoteDecKey = mkPreludeMiscIdUnique 425 +quoteTypeKey = mkPreludeMiscIdUnique 426 + +-- data RuleBndr = ... +ruleVarIdKey, typedRuleVarIdKey :: Unique +ruleVarIdKey = mkPreludeMiscIdUnique 427 +typedRuleVarIdKey = mkPreludeMiscIdUnique 428 diff --git a/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs b/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/DsUtils.lhs @@ -0,0 +1,835 @@ +% +% (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. + +\begin{code} +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + +-- | Utility functions for constructing Core syntax, principally for desugaring +module Language.Haskell.Liquid.Desugar.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, + + 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.Desugar.Match ( matchSimply ) + +import HsSyn +import TcHsSyn +import TcType( tcSplitTyConApp ) +import CoreSyn +import DsMonad +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsLExpr ) + +import CoreUtils +import MkCore +import MkId +import Id +import Literal +import TyCon +import ConLike +import DataCon +import PatSyn +import Type +import Coercion +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 ) +\end{code} + + +%************************************************************************ +%* * +\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. + +\begin{code} +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... +\end{code} + +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. + +\begin{code} +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 ] +\end{code} + +Functions on MatchResults + +\begin{code} +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 + +\end{code} + +\begin{code} +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, cont, fail] + where + MkCaseAlt{ alt_pat = psyn, + alt_bndrs = bndrs, + alt_wrapper = wrapper, + alt_result = match_result} = alt + matcher = patSynMatcher psyn + +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] +\end{code} + +%************************************************************************ +%* * +\subsection{Desugarer's versions of some Core functions} +%* * +%************************************************************************ + +\begin{code} +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]) +\end{code} + +'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'. + +\begin{code} +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 +\end{code} + + +%************************************************************************ +%* * +\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 + +\begin{code} +mkSelectorBinds :: [Maybe (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 use coerce for that + ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID unitTy (ppr pat) + ; err_var <- newSysLocalDs unitTy + ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders + ; return ( (val_var, val_expr) : + (err_var, err_expr) : + 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 Nothing + + 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 -> coerce (type-of-bv) err_var } + -- 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 = mkCast (Var err_var) co + co = mkUnsafeCo (exprType (Var err_var)) (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 +\end{code} + +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. + +\begin{code} +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 +\end{code} + +%************************************************************************ +%* * +\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. + +\begin{code} +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 +\end{code} + +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. + +\begin{code} +mkOptTickBox :: Maybe (Tickish Id) -> CoreExpr -> CoreExpr +mkOptTickBox Nothing e = e +mkOptTickBox (Just tickish) e = Tick tickish e + +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) + ] +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/HscMain.hs b/src/Language/Haskell/Liquid/Desugar/HscMain.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/HscMain.hs @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------- +-- +-- | 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.Desugar.HscMain (hscDesugarWithLoc) where + +import Language.Haskell.Liquid.Desugar.Desugar (deSugarWithLoc) + +import Module +import Packages +import RdrName +import HsSyn +import CoreSyn +import StringBuffer +import Parser +import Lexer +import SrcLoc +import TcRnDriver +import TcIface ( typecheckIface ) +import TcRnMonad +import IfaceEnv ( initNameCache ) +import LoadIface ( ifaceStats, initExternalPackageState ) +import PrelInfo +import MkIface +import SimplCore +import TidyPgm +import CorePrep +import CoreToStg ( coreToStg ) +import qualified StgCmm ( codeGen ) +import StgSyn +import CostCentre +import ProfInit +import TyCon +import Name +import SimplStg ( stg2stg ) +import Cmm +import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables +import CmmPipeline +import CmmInfo +import CodeOutput +import NameEnv ( emptyNameEnv ) +import NameSet ( emptyNameSet ) +import InstEnv +import FamInstEnv +import Fingerprint ( Fingerprint ) +import Hooks + +import DynFlags +import ErrUtils + +import Outputable +import HscStats ( ppSourceStats ) +import HscTypes +import MkExternalCore ( emitExternalCore ) +import FastString +import UniqFM ( emptyUFM ) +import UniqSupply +import Bag +import Exception +import qualified Stream +import Stream (Stream) + +import Util + +import Data.List +import Control.Monad +import Data.Maybe +import Data.IORef +import System.FilePath as FilePath +import System.Directory + + +-- ----------------------------------------------------------------------------- + +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) + + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not $ isEmptyBag errs) $ throwErrors errs + +-- | 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/Desugar/Match.lhs b/src/Language/Haskell/Liquid/Desugar/Match.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/Match.lhs @@ -0,0 +1,1049 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +The @match@ function + +\begin{code} +module Language.Haskell.Liquid.Desugar.Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat ) where + +-- #include "HsVersions.h" + +import {-#SOURCE#-} Language.Haskell.Liquid.Desugar.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.Desugar.DsBinds +import Language.Haskell.Liquid.Desugar.DsGRHSs +import Language.Haskell.Liquid.Desugar.DsUtils +import Id +import ConLike +import DataCon +import PatSyn +import Language.Haskell.Liquid.Desugar.MatchCon +import Language.Haskell.Liquid.Desugar.MatchLit +import Type +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 +\end{code} + +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 + +\begin{code} +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 +\end{code} + +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?) + +\begin{code} +maximum_output :: Int +maximum_output = 4 +\end{code} + +The next two functions create the warning message. + +\begin{code} +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)) +\end{code} + + +%************************************************************************ +%* * + 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@. + +\begin{code} +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" +\end{code} + +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} + +\begin{code} +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 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 bang around strict pattern +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 +tidy_bang_pat v _ p@(ConPatOut {}) = tidy1 v p +tidy_bang_pat v _ p@(LitPat {}) = tidy1 v p + +-- 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) + +-- Default case, leave the bang there: +-- VarPat, LazyPat, WildPat, ViewPat, NPat, NPlusKPat +-- For LazyPat, remember that it's semantically like a VarPat +-- i.e. !(~p) is not like ~p, or p! (Trac #8952) + +tidy_bang_pat _ l p = return (idDsWrapper, BangPat (L l p)) + -- NB: SigPatIn, ConPatIn should not happen +\end{code} + +\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} + +\begin{code} +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> MatchGroup Id (LHsExpr Id) -- Matches being desugared + -> DsM ([Id], CoreExpr) -- Results +\end{code} + + 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 + +\begin{code} +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 } +\end{code} + +%************************************************************************ +%* * +\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. + +\begin{code} +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') } +\end{code} + + +%************************************************************************ +%* * + Pattern classification +%* * +%************************************************************************ + +\begin{code} +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 +\end{code} + +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! + + +\begin{code} +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 (Present e1) (Present e2) = lexp e1 e2 + tup_arg (Missing t1) (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 (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 olit mb_neg _) = PgN (hsOverLitKey olit (isJust mb_neg)) +patGroup _ (NPlusKPat _ 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) +\end{code} + +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/Desugar/Match.lhs-boot b/src/Language/Haskell/Liquid/Desugar/Match.lhs-boot new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/Match.lhs-boot @@ -0,0 +1,35 @@ +\begin{code} +module Language.Haskell.Liquid.Desugar.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 +\end{code} diff --git a/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs b/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/MatchCon.lhs @@ -0,0 +1,293 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Pattern-matching constructors + +\begin{code} +{-# OPTIONS -fno-warn-tabs #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and +-- detab the module (please do the detabbing in a separate patch). See +-- http://ghc.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces +-- for details + +module Language.Haskell.Liquid.Desugar.MatchCon ( matchConFamily, matchPatSyn ) where + +-- #include "HsVersions.h" + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( match ) + +import HsSyn +import DsBinds +import ConLike +import DataCon +import PatSyn +import TcType +import DsMonad +import Language.Haskell.Liquid.Desugar.DsUtils +import MkCore ( mkCoreLets ) +import Util +import ListSetOps ( runs ) +import Id +import NameEnv +import SrcLoc +import DynFlags +import Outputable +import Control.Monad(liftM) +\end{code} + +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. +\begin{code} +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 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 (\f1 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) rpats +\end{code} + +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/Desugar/MatchLit.lhs b/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Desugar/MatchLit.lhs @@ -0,0 +1,471 @@ +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +Pattern-matching literal patterns + +\begin{code} +{-# LANGUAGE RankNTypes #-} + +module Language.Haskell.Liquid.Desugar.MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey + , tidyLitPat, tidyNPat + , matchLiterals, matchNPlusKPats, matchNPats + , warnAboutIdentities, warnAboutEmptyEnumerations + ) where + +-- #include "HsVersions.h" + +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.Match ( match ) +import {-# SOURCE #-} Language.Haskell.Liquid.Desugar.DsExpr ( dsExpr ) + +import DsMonad +import Language.Haskell.Liquid.Desugar.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 MonadUtils +import Outputable +import BasicTypes +import DynFlags +import Util +import FastString +import Control.Monad + +import Data.Int +import Data.Traversable (traverse) +import Data.Word +\end{code} + +%************************************************************************ +%* * + 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. + +\begin{code} +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 +\end{code} + +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 + +\begin{code} +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 +\end{code} + +\begin{code} +warnAboutOverflowedLiterals :: DynFlags -> HsOverLit Id -> DsM () +warnAboutOverflowedLiterals dflags lit +-- | wopt Opt_WarnOverflowedLiterals dflags +-- , Just (i, tc) <- getIntegralLit lit +-- = if tc == intTyConName then check i tc (undefined :: Int) +-- else if tc == int8TyConName then check i tc (undefined :: Int8) +-- else if tc == int16TyConName then check i tc (undefined :: Int16) +-- else if tc == int32TyConName then check i tc (undefined :: Int32) +-- else if tc == int64TyConName then check i tc (undefined :: Int64) +-- else if tc == wordTyConName then check i tc (undefined :: Word) +-- else if tc == word8TyConName then check i tc (undefined :: Word8) +-- else if tc == word16TyConName then check i tc (undefined :: Word16) +-- else if tc == word32TyConName then check i tc (undefined :: Word32) +-- else if tc == word64TyConName then check i tc (undefined :: Word64) +-- else return () +-- + | otherwise = return () +-- where +-- check :: forall a. (Bounded a, Integral a) => Integer -> Name -> a -> DsM () +-- check i tc _proxy +-- = when (i < minB || i > maxB) $ do +-- warnDs (vcat [ ptext (sLit "Literal") <+> integer i +-- <+> ptext (sLit "is out of the") <+> ppr tc <+> ptext (sLit "range") +-- <+> integer minB <> ptext (sLit "..") <> integer maxB +-- , sug ]) +-- where +-- minB = toInteger (minBound :: a) +-- maxB = toInteger (maxBound :: a) +-- sug | minB == -i -- Note [Suggest NegativeLiterals] +-- , i > 0 +-- , not (xopt Opt_NegativeLiterals dflags) +-- = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals") +-- | otherwise = empty +\end{code} + +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. + +\begin{code} +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 +-- | wopt Opt_WarnEmptyEnumerations dflags +-- , Just (from,tc) <- getLHsIntegralLit fromExpr +-- , Just mThn <- traverse getLHsIntegralLit mThnExpr +-- , Just (to,_) <- getLHsIntegralLit toExpr +-- , let check :: forall a. (Enum a, Num a) => a -> DsM () +-- check _proxy +-- = when (null enumeration) $ +-- warnDs (ptext (sLit "Enumeration is empty")) +-- where +-- enumeration :: [a] +-- enumeration = case mThn of +-- Nothing -> [fromInteger from .. fromInteger to] +-- Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] +-- +-- = if tc == intTyConName then check (undefined :: Int) +-- else if tc == int8TyConName then check (undefined :: Int8) +-- else if tc == int16TyConName then check (undefined :: Int16) +-- else if tc == int32TyConName then check (undefined :: Int32) +-- else if tc == int64TyConName then check (undefined :: Int64) +-- else if tc == wordTyConName then check (undefined :: Word) +-- else if tc == word8TyConName then check (undefined :: Word8) +-- else if tc == word16TyConName then check (undefined :: Word16) +-- else if tc == word32TyConName then check (undefined :: Word32) +-- else if tc == word64TyConName then check (undefined :: Word64) +-- else return () +-- + | otherwise = return () + +getLHsIntegralLit :: LHsExpr Id -> Maybe (Integer, Name) +-- See if the expression is an Integral literal +-- Remember to look through automatically-added tick-boxes! (Trac #8384) +getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e +getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit +getLHsIntegralLit _ = Nothing + +getIntegralLit :: HsOverLit Id -> Maybe (Integer, Name) +getIntegralLit (OverLit { ol_val = HsIntegral i, ol_type = ty }) + | Just tc <- tyConAppTyCon_maybe ty + = Just (i, tyConName tc) +getIntegralLit _ = Nothing +\end{code} + + +%************************************************************************ +%* * + Tidying lit pats +%* * +%************************************************************************ + +\begin{code} +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 c) = unLoc (mkCharLitPat c) +tidyLitPat (HsString s) + | lengthFS s <= 1 -- Short string literals only + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat 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 over_lit mb_neg eq +\end{code} + + +%************************************************************************ +%* * + Pattern matching on LitPat +%* * +%************************************************************************ + +\begin{code} +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? + s' <- liftIO $ 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) +\end{code} + +%************************************************************************ +%* * + Pattern matching on NPat +%* * +%************************************************************************ + +\begin{code} +matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +matchNPats (var:vars) ty (eqn1:eqns) -- All for the same literal + = do { let NPat 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)) +\end{code} + + +%************************************************************************ +%* * + 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} + + +\begin{code} +matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult +-- All NPlusKPats, for the *same* literal k +matchNPlusKPats (var:vars) ty (eqn1:eqns) + = do { let NPlusKPat (L _ n1) 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)) +\end{code} diff --git a/src/Language/Haskell/Liquid/DiffCheck.hs b/src/Language/Haskell/Liquid/DiffCheck.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/DiffCheck.hs @@ -0,0 +1,454 @@ +-- | This module contains the code for Incremental checking, which finds the +-- part of a target file (the subset of the @[CoreBind]@ that have been +-- modified since it was last checked, as determined by a diff against +-- a saved version of the file. + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Haskell.Liquid.DiffCheck ( + + -- * Changed binders + Unchanged Errors + DiffCheck (..) + + -- * Use previously saved info to generate DiffCheck target + , slice + + -- * Use target binders to generate DiffCheck target + , thin + + -- * Save current information for next time + , saveResult + + ) + where + +import Control.Applicative ((<$>), (<*>)) +import Data.Aeson +import qualified Data.Text as T +import Data.Algorithm.Diff +import Data.Monoid (mempty) +import Data.Maybe (listToMaybe, mapMaybe, fromMaybe) +import Data.Hashable +import qualified Data.IntervalMap.FingerTree as IM +import CoreSyn +import Name +import SrcLoc +import Var +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import qualified Data.List as L +import Data.Function (on) +import System.Directory (copyFile, doesFileExist) +import Language.Fixpoint.Misc (traceShow) +import Language.Fixpoint.Types (FixResult (..)) +import Language.Fixpoint.Files +import Language.Haskell.Liquid.Types (errSpan, AnnInfo (..), Error, TError (..), Output (..)) +import Language.Haskell.Liquid.GhcInterface +import Language.Haskell.Liquid.GhcMisc +import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos) +import Text.PrettyPrint.HughesPJ (text, render, Doc) +import Control.Monad (forM, forM_) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB + +------------------------------------------------------------------------- +-- Data Types ----------------------------------------------------------- +------------------------------------------------------------------------- + +-- | Main type of value returned for diff-check. +data DiffCheck = DC { newBinds :: [CoreBind] + , oldOutput :: !(Output Doc) + } + +data Def = D { start :: Int -- ^ line at which binder definition starts + , end :: Int -- ^ line at which binder definition ends + , binder :: Var -- ^ name of binder + } + deriving (Eq, Ord) + +-- | Variable dependencies "call-graph" +type Deps = M.HashMap Var (S.HashSet Var) + +-- | Map from saved-line-num ---> current-line-num +type LMap = IM.IntervalMap Int Int + +-- | Intervals of line numbers that have been re-checked +type ChkItv = IM.IntervalMap Int () + + +instance Show Def where + show (D i j x) = showPpr x ++ " start: " ++ show i ++ " end: " ++ show j + + + +-- | `slice` returns a subset of the @[CoreBind]@ of the input `target` +-- file which correspond to top-level binders whose code has changed +-- and their transitive dependencies. +------------------------------------------------------------------------- +slice :: FilePath -> [CoreBind] -> IO (Maybe DiffCheck) +------------------------------------------------------------------------- +slice target cbs = ifM (doesFileExist saved) (Just <$> dc) (return Nothing) + where + saved = extFileName Saved target + dc = sliceSaved target saved cbs + +sliceSaved :: FilePath -> FilePath -> [CoreBind] -> IO DiffCheck +sliceSaved target saved cbs + = do (is, lm) <- lineDiff target saved + res <- loadResult target + return $ sliceSaved' is lm (DC cbs res) + +sliceSaved' :: [Int] -> LMap -> DiffCheck -> DiffCheck +sliceSaved' is lm dc = DC cbs' res' + where + cbs' = thin cbs $ diffVars is dfs + res' = adjustOutput lm cm res + cm = checkedItv chDfs + dfs = coreDefs cbs + chDfs = coreDefs cbs' + DC cbs res = dc + +-- | @thin@ returns a subset of the @[CoreBind]@ given which correspond +-- to those binders that depend on any of the @Var@s provided. +------------------------------------------------------------------------- +thin :: [CoreBind] -> [Var] -> [CoreBind] +------------------------------------------------------------------------- +thin cbs xs = filterBinds cbs ys + where + ys = dependentVars (coreDeps cbs) $ S.fromList xs + + +------------------------------------------------------------------------- +filterBinds :: [CoreBind] -> S.HashSet Var -> [CoreBind] +------------------------------------------------------------------------- +filterBinds cbs ys = filter f cbs + where + f (NonRec x _) = x `S.member` ys + f (Rec xes) = any (`S.member` ys) $ fst <$> xes + + +------------------------------------------------------------------------- +coreDefs :: [CoreBind] -> [Def] +------------------------------------------------------------------------- +coreDefs cbs = L.sort [D l l' x | b <- cbs, let (l, l') = coreDef b, x <- bindersOf b] +coreDef b = meetSpans b eSp vSp + where + eSp = lineSpan b $ catSpans b $ bindSpans b + vSp = lineSpan b $ catSpans b $ getSrcSpan <$> bindersOf b + + +-- | `meetSpans` cuts off the start-line to be no less than the line at which +-- the binder is defined. Without this, i.e. if we ONLY use the ticks and +-- spans appearing inside the definition of the binder (i.e. just `eSp`) +-- then the generated span can be WAY before the actual definition binder, +-- possibly due to GHC INLINE pragmas or dictionaries OR ... +-- for an example: see the "INCCHECK: Def" generated by +-- liquid -d benchmarks/bytestring-0.9.2.1/Data/ByteString.hs +-- where `spanEnd` is a single line function around 1092 but where +-- the generated span starts mysteriously at 222 where Data.List is imported. + +meetSpans b Nothing _ + = error $ "INCCHECK: cannot find span for top-level binders: " + ++ showPpr (bindersOf b) + ++ "\nRun without --diffcheck option\n" + +meetSpans b (Just (l,l')) Nothing + = (l, l') +meetSpans b (Just (l,l')) (Just (m,_)) + = (max l m, l') + +lineSpan _ (RealSrcSpan sp) = Just (srcSpanStartLine sp, srcSpanEndLine sp) +lineSpan b _ = Nothing + +catSpans b [] = error $ "INCCHECK: catSpans: no spans found for " ++ showPpr b +catSpans b xs = foldr1 combineSrcSpans [x | x@(RealSrcSpan z) <- xs, bindFile b == srcSpanFile z] + +bindFile (NonRec x _) = varFile x +bindFile (Rec xes) = varFile $ fst $ head xes + +varFile b = case getSrcSpan b of + RealSrcSpan z -> srcSpanFile z + _ -> error $ "INCCHECK: getFile: no file found for: " ++ showPpr b + + +bindSpans (NonRec x e) = getSrcSpan x : exprSpans e +bindSpans (Rec xes) = map getSrcSpan xs ++ concatMap exprSpans es + where + (xs, es) = unzip xes + +exprSpans (Tick t e) + | isJunkSpan sp = exprSpans e + | otherwise = [sp] + where + sp = tickSrcSpan t + +exprSpans (Var x) = [getSrcSpan x] +exprSpans (Lam x e) = getSrcSpan x : exprSpans e +exprSpans (App e a) = exprSpans e ++ exprSpans a +exprSpans (Let b e) = bindSpans b ++ exprSpans e +exprSpans (Cast e _) = exprSpans e +exprSpans (Case e x _ cs) = getSrcSpan x : exprSpans e ++ concatMap altSpans cs +exprSpans e = [] + +altSpans (_, xs, e) = map getSrcSpan xs ++ exprSpans e + +isJunkSpan (RealSrcSpan _) = False +isJunkSpan _ = True + +------------------------------------------------------------------------- +coreDeps :: [CoreBind] -> Deps +------------------------------------------------------------------------- +coreDeps = M.fromList . concatMap bindDep + +bindDep b = [(x, ys) | x <- bindersOf b] + where + ys = S.fromList $ freeVars S.empty b + +------------------------------------------------------------------------- +dependentVars :: Deps -> S.HashSet Var -> S.HashSet Var +------------------------------------------------------------------------- +dependentVars d = {- tracePpr "INCCHECK: tx changed vars" $ -} + go S.empty {- tracePpr "INCCHECK: seed changed vars" -} + where + pre = S.unions . fmap deps . S.toList + deps x = M.lookupDefault S.empty x d + go seen new + | S.null new = seen + | otherwise = let seen' = S.union seen new + new' = pre new `S.difference` seen' + in go seen' new' + +------------------------------------------------------------------------- +diffVars :: [Int] -> [Def] -> [Var] +------------------------------------------------------------------------- +diffVars lines defs' = -- tracePpr ("INCCHECK: diffVars lines = " ++ show lines ++ " defs= " ++ show defs) $ + go (L.sort lines) defs + where + defs = L.sort defs' + go _ [] = [] + go [] _ = [] + go (i:is) (d:ds) + | i < start d = go is (d:ds) + | i > end d = go (i:is) ds + | otherwise = binder d : go (i:is) ds + +------------------------------------------------------------------------- +-- Diff Interface ------------------------------------------------------- +------------------------------------------------------------------------- + + +-- | `lineDiff new old` compares the contents of `src` with `dst` +-- and returns the lines of `src` that are different. +------------------------------------------------------------------------- +lineDiff :: FilePath -> FilePath -> IO ([Int], LMap) +------------------------------------------------------------------------- +lineDiff new old = lineDiff' <$> getLines new <*> getLines old + where + getLines = fmap lines . readFile + +lineDiff' :: [String] -> [String] -> ([Int], LMap) +lineDiff' new old = (ns, lm) + where + ns = diffLines 1 diff + lm = foldr setShift IM.empty $ diffShifts diff + diff = fmap length <$> getGroupedDiff new old + +diffLines _ [] = [] +diffLines n (Both i _ : d) = diffLines n' d where n' = n + i -- length ls +diffLines n (First i : d) = [n .. (n' - 1)] ++ diffLines n' d where n' = n + i -- length ls +diffLines n (Second _ : d) = diffLines n d + +diffShifts :: [Diff Int] -> [(Int, Int, Int)] +diffShifts = go 1 1 + where + go old new (Both n _ : d) = (old, old + n - 1, new - old) : go (old + n) (new + n) d + go old new (Second n : d) = go (old + n) new d + go old new (First n : d) = go old (new + n) d + go _ _ [] = [] + +instance Functor Diff where + fmap f (First x) = First (f x) + fmap f (Second x) = Second (f x) + fmap f (Both x y) = Both (f x) (f y) + +-- | @save@ creates an .saved version of the @target@ file, which will be +-- used to find what has changed the /next time/ @target@ is checked. +------------------------------------------------------------------------- +saveResult :: FilePath -> Output Doc -> IO () +------------------------------------------------------------------------- +saveResult target res + = do copyFile target saveF + B.writeFile errF $ LB.toStrict $ encode res + where + saveF = extFileName Saved target + errF = extFileName Cache target + +------------------------------------------------------------------------- +loadResult :: FilePath -> IO (Output Doc) +------------------------------------------------------------------------- +loadResult f = ifM (doesFileExist jsonF) out (return mempty) + where + jsonF = extFileName Cache f + out = (fromMaybe mempty . decode . LB.fromStrict) <$> B.readFile jsonF + +------------------------------------------------------------------------- +adjustOutput :: LMap -> ChkItv -> Output Doc -> Output Doc +------------------------------------------------------------------------- +adjustOutput lm cm o = mempty { o_types = adjustTypes lm cm (o_types o) } + { o_result = adjustResult lm cm (o_result o) } + +adjustTypes :: LMap -> ChkItv -> AnnInfo a -> AnnInfo a +adjustTypes lm cm (AI m) = AI $ M.fromList + [(sp', v) | (sp, v) <- M.toList m + , Just sp' <- [adjustSrcSpan lm cm sp]] + +adjustResult :: LMap -> ChkItv -> FixResult Error -> FixResult Error +adjustResult lm cm (Unsafe es) = errorsResult Unsafe $ adjustErrors lm cm es +adjustResult lm cm (Crash es z) = errorsResult (`Crash` z) $ adjustErrors lm cm es +adjustResult _ _ r = r + +errorsResult f [] = Safe +errorsResult f es = f es + +adjustErrors lm cm = mapMaybe adjustError + where + adjustError (ErrSaved sp msg) = (`ErrSaved` msg) <$> adjustSrcSpan lm cm sp + adjustError e = Just e + +------------------------------------------------------------------------- +adjustSrcSpan :: LMap -> ChkItv -> SrcSpan -> Maybe SrcSpan +------------------------------------------------------------------------- +adjustSrcSpan lm cm sp + = do sp' <- adjustSpan lm sp + if isCheckedSpan cm sp' + then Nothing + else Just sp' + +isCheckedSpan cm (RealSrcSpan sp) = isCheckedRealSpan cm sp +isCheckedSpan _ _ = False +isCheckedRealSpan cm = not . null . (`IM.search` cm) . srcSpanStartLine + +adjustSpan lm (RealSrcSpan rsp) = RealSrcSpan <$> adjustReal lm rsp +adjustSpan lm sp = Just sp +adjustReal lm rsp + | Just δ <- getShift l1 lm = Just $ realSrcSpan f (l1 + δ) c1 (l2 + δ) c2 + | otherwise = Nothing + where + (f, l1, c1, l2, c2) = unpackRealSrcSpan rsp + +-- DELETE unCheckedDefs cd = filter (not . isCheckedError cm) +-- DELETE where +-- DELETE cm = checkedItv cd +-- DELETE +-- DELETE isCheckedError cm e +-- DELETE | RealSrcSpan sp <- errSpan e = isCheckedSpan sp +-- DELETE | otherwise = False + + +-- | @getShift lm old@ returns @Just δ@ if the line number @old@ shifts by @δ@ +-- in the diff and returns @Nothing@ otherwise. +getShift :: Int -> LMap -> Maybe Int +getShift old = fmap snd . listToMaybe . IM.search old + +-- | @setShift (lo, hi, δ) lm@ updates the interval map @lm@ appropriately +setShift :: (Int, Int, Int) -> LMap -> LMap +setShift (l1, l2, δ) = IM.insert (IM.Interval l1 l2) δ + + +checkedItv :: [Def] -> ChkItv +checkedItv chDefs = foldr (`IM.insert` ()) IM.empty is + where + is = [IM.Interval l1 l2 | D l1 l2 _ <- chDefs] + + +ifM b x y = b >>= \z -> if z then x else y + +------------------------------------------------------------------------- +-- | Aeson instances ---------------------------------------------------- +------------------------------------------------------------------------- + +instance ToJSON SourcePos where + toJSON p = object [ "sourceName" .= f + , "sourceLine" .= l + , "sourceColumn" .= c + ] + where + f = sourceName p + l = sourceLine p + c = sourceColumn p + +instance FromJSON SourcePos where + parseJSON (Object v) = newPos <$> v .: "sourceName" + <*> v .: "sourceLine" + <*> v .: "sourceColumn" + parseJSON _ = mempty + + +instance ToJSON (FixResult Error) +instance FromJSON (FixResult Error) + +instance ToJSON Doc where + toJSON = String . T.pack . render + +instance FromJSON Doc where + parseJSON (String s) = return $ text $ T.unpack s + parseJSON _ = mempty + +instance (ToJSON k, ToJSON v) => ToJSON (M.HashMap k v) where + toJSON = toJSON . M.toList + +instance (Eq k, Hashable k, FromJSON k, FromJSON v) => FromJSON (M.HashMap k v) where + parseJSON = fmap M.fromList . parseJSON + +instance ToJSON a => ToJSON (AnnInfo a) +instance FromJSON a => FromJSON (AnnInfo a) + +instance ToJSON (Output Doc) +instance FromJSON (Output Doc) + +-- Move to Fixpoint +-- instance ToJSON Symbol +-- instance FromJSON Symbol +-- instance ToJSON Subst +-- instance FromJSON Subst +-- instance ToJSON Sort +-- instance FromJSON Sort +-- instance ToJSON SymConst +-- instance FromJSON SymConst +-- instance ToJSON Constant +-- instance FromJSON Constant +-- instance ToJSON Bop +-- instance FromJSON Bop +-- instance ToJSON Brel +-- instance FromJSON Brel +-- instance ToJSON LocSymbol +-- instance FromJSON LocSymbol +-- instance ToJSON FTycon +-- instance FromJSON FTycon +-- instance ToJSON Expr +-- instance FromJSON Expr +-- instance ToJSON Pred +-- instance FromJSON Pred +-- instance ToJSON Refa +-- instance FromJSON Refa +-- instance ToJSON Reft +-- instance FromJSON Reft +-- +-- -- Move to Types +-- instance ToJSON Predicate +-- instance FromJSON Predicate +-- instance ToJSON LParseError +-- instance FromJSON LParseError +-- instance ToJSON Oblig +-- instance FromJSON Oblig +-- instance ToJSON Stratum +-- instance FromJSON Stratum +-- instance ToJSON RReft +-- instance FromJSON RReft +-- instance ToJSON UsedPVar +-- instance FromJSON UsedPVar +-- instance ToJSON EMsg +-- instance FromJSON EMsg + diff --git a/src/Language/Haskell/Liquid/Errors.hs b/src/Language/Haskell/Liquid/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Errors.hs @@ -0,0 +1,252 @@ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 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 + + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (Exception (..)) +import Data.Aeson +import Data.Hashable +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.Text as T +import Data.List (sortBy, intersperse) +import Data.Function (on) +import Data.Maybe (fromMaybe, maybeToList) +import Data.Monoid hiding ((<>)) +import Language.Fixpoint.Misc hiding (intersperse) +import Language.Fixpoint.Types hiding (shiftVV) +import Language.Haskell.Liquid.PrettyPrint +import Language.Haskell.Liquid.RefType +import Language.Haskell.Liquid.Tidy +import Language.Haskell.Liquid.Types +import SrcLoc (SrcSpan) +import Text.PrettyPrint.HughesPJ +import Control.Arrow (second) + +type Ctx = M.HashMap Symbol SpecType + +------------------------------------------------------------------------ +tidyError :: FixSolution -> Error -> Error +------------------------------------------------------------------------ +tidyError sol + = fmap (tidySpecType Full) + . tidyErrContext sol + . applySolution sol + +tidyErrContext s err@(ErrSubType {}) + = err { ctx = c', tact = subst θ tA, texp = subst θ tE } + where + (θ, c') = tidyCtx xs $ ctx err + xs = syms tA ++ syms tE + tA = tact err + tE = texp err + +tidyErrContext _ err + = err + +--------------------------------------------------------------------------------- +tidyCtx :: [Symbol] -> Ctx -> (Subst, Ctx) +--------------------------------------------------------------------------------- +tidyCtx xs m = (θ, M.fromList yts) + where + yts = [tBind x t | (x, t) <- xts] + (θ, xts) = tidyTemps $ second stripReft <$> tidyREnv xs m + tBind x t = (x', shiftVV t x') where x' = tidySymbol x + + +stripReft :: SpecType -> SpecType +stripReft t = maybe t' (strengthen t') ro + where + (t', ro) = stripRType t + +stripRType :: SpecType -> (SpecType, Maybe RReft) +stripRType t = (t', ro) + where + t' = fmap (const (uTop mempty)) t + ro = stripRTypeBase t + +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 + +expandFix :: (Eq a, Hashable a) => (a -> [a]) -> [a] -> [a] +expandFix f xs = S.toList $ go S.empty xs + where + go seen [] = seen + go seen (x:xs) + | x `S.member` seen = go seen xs + | otherwise = go (S.insert x seen) (f x ++ xs) + +tidyTemps :: (Subable t) => [(Symbol, t)] -> (Subst, [(Symbol, t)]) +tidyTemps xts = (θ, [(txB x, txTy t) | (x, t) <- xts]) + where + txB x = M.lookupDefault x x m + txTy = subst θ + m = M.fromList yzs + θ = mkSubst [(y, EVar z) | (y, z) <- yzs] + yzs = zip ys niceTemps + ys = [ x | (x,_) <- xts, isTmpSymbol x] + +niceTemps :: [Symbol] +niceTemps = mkSymbol <$> xs ++ ys + where + mkSymbol = symbol . ('?' :) + xs = single <$> ['a' .. 'z'] + ys = ("a" ++) <$> [show n | n <- [0 ..]] + + +------------------------------------------------------------------------ +-- | Pretty Printing Error Messages ------------------------------------ +------------------------------------------------------------------------ + +-- | 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 + +ppSpecTypeErr :: SpecType -> Doc +ppSpecTypeErr t + | isTrivial t = dt + | otherwise = dt <+> dr + where + dt = rtypeDoc Lossy t' + dr = maybe empty ((text "|" <+>) . pprint) ro + (t', ro) = stripRType t + +-- full = isNontrivialVV $ rTypeValueVar t = + +instance Show Error where + show = showpp + +instance Exception Error +instance Exception [Error] + +------------------------------------------------------------------------ +ppError :: (PPrint a) => Tidy -> TError a -> Doc +------------------------------------------------------------------------ + +ppError k e = ppError' k (pprintE $ errSpan e) e +pprintE l = pprint l <> text ": Error:" + +nests n = foldr (\d acc -> nest n (d $+$ acc)) empty + +sepVcat d ds = vcat $ intersperse d ds +blankLine = sizedText 5 " " + +------------------------------------------------------------------------ +ppError' :: (PPrint a) => Tidy -> Doc -> TError a -> Doc +----------------------------------------------------------------------- + +ppError' _ dSp (ErrAssType _ OTerm s r) + = dSp <+> text "Termination Check" + +ppError' _ dSp (ErrAssType _ OInv s r) + = dSp <+> text "Invariant Check" + +ppError' Lossy dSp (ErrSubType _ s c tA tE) + = dSp <+> text "Liquid Type Mismatch" + +ppError' Full dSp (ErrSubType _ s c tA tE) + = dSp <+> text "Liquid Type Mismatch" + $+$ sepVcat blankLine + [ nests 2 [ text "Inferred type" + , text "VV :" <+> pprint tA] + , nests 2 [ text "not a subtype of Required type" + , text "VV :" <+> pprint tE] + , nests 2 [ text "In Context" + , pprint c ]] + +ppError' _ dSp (ErrParse _ _ e) + = dSp <+> text "Cannot parse specification:" + $+$ (nest 4 $ pprint e) + +ppError' _ dSp (ErrTySpec _ v t s) + = dSp <+> text "Bad Type Specification" + $+$ (pprint v <+> dcolon <+> pprint t) + $+$ (nest 4 $ pprint s) + +ppError' _ dSp (ErrInvt _ t s) + = dSp <+> text "Bad Invariant Specification" + $+$ (nest 4 $ text "invariant " <+> pprint t $+$ pprint s) + +ppError' _ dSp (ErrIAl _ t s) + = dSp <+> text "Bad Using Specification" + $+$ (nest 4 $ text "as" <+> pprint t $+$ pprint s) + +ppError' _ dSp (ErrIAlMis _ t1 t2 s) + = dSp <+> text "Incompatible Using Specification" + $+$ (nest 4 $ (text "using" <+> pprint t1 <+> text "as" <+> pprint t2) $+$ pprint s) + +ppError' _ dSp (ErrMeas _ t s) + = dSp <+> text "Bad Measure Specification" + $+$ (nest 4 $ text "measure " <+> pprint t $+$ pprint s) + +ppError' _ dSp (ErrDupSpecs _ v ls) + = dSp <+> text "Multiple Specifications for" <+> pprint v <> colon + $+$ (nest 4 $ vcat $ pprint <$> ls) + +ppError' _ dSp (ErrDupAlias _ k v ls) + = dSp <+> text "Multiple Declarations! " + $+$ (nest 2 $ text "Multiple Declarations of" <+> pprint k <+> ppVar v $+$ text "Declared at:") + <+> (nest 4 $ vcat $ pprint <$> ls) + +ppError' _ dSp (ErrUnbound _ x) + = dSp <+> text "Unbound variable" + $+$ (nest 4 $ pprint x) + +ppError' _ dSp (ErrGhc _ s) + = dSp <+> text "GHC Error" + $+$ (nest 4 $ pprint s) + +ppError' _ dSp (ErrMismatch _ x τ t) + = dSp <+> text "Specified Type Does Not Refine Haskell Type for" <+> pprint x + $+$ text "Haskell:" <+> pprint τ + $+$ text "Liquid :" <+> pprint t + +ppError' _ dSp (ErrSaved _ s) + = dSp <+> s + +ppError' _ _ (ErrOther _ s) + = text "Panic!" <+> nest 4 (pprint s) + + +ppVar v = text "`" <> pprint v <> text "'" + + +-- instance (Ord k, PPrint k, PPrint v) => PPrint (M.HashMap k v) where +-- pprint = ppTable + +-- ppXTS xts' = vcat $ ppXT n <$> xts +-- where +-- n = 1 + maximum [ i | (x, _) <- xts, let i = keySize x, i <= thresh ] +-- keySize = length . render . pprint +-- xts = sortBy (compare `on` fst) xts' -- $ M.toList m +-- thresh = 6 +-- +-- ppXT n (x,t) = pprint x $$ nest n (colon <+> pprint t) +-- where x = rTypeValueVar t + +instance ToJSON Error where + toJSON e = object [ "pos" .= (errSpan e) + , "msg" .= (render $ ppError' Full empty e) + ] + +instance FromJSON Error where + parseJSON (Object v) = errSaved <$> v .: "pos" + <*> v .: "msg" + parseJSON _ = mempty + + +errSaved :: SrcSpan -> String -> Error +errSaved x = ErrSaved x . text diff --git a/src/Language/Haskell/Liquid/Fresh.hs b/src/Language/Haskell/Liquid/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Fresh.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Haskell.Liquid.Fresh (Freshable(..)) where + +import Control.Applicative (Applicative, (<$>), (<*>)) +import Data.Monoid (mempty) +import Language.Fixpoint.Misc +import Language.Fixpoint.Types +import Language.Haskell.Liquid.Types + +class (Applicative m, Monad m) => Freshable m a where + fresh :: m a + true :: a -> m a + true = return . id + refresh :: a -> m a + refresh = return . id + +instance Freshable m Integer => Freshable m Symbol where + fresh = tempSymbol "x" <$> fresh + +instance Freshable m Integer => Freshable m Refa where + fresh = ((`RKvar` mkSubst []) . intKvar) <$> fresh + +instance Freshable m Integer => Freshable m [Refa] where + fresh = single <$> fresh + +instance Freshable m Integer => Freshable m Reft where + fresh = errorstar "fresh Reft" + true (Reft (v,_)) = return $ Reft (v, []) + refresh (Reft (_,_)) = (Reft .) . (,) <$> freshVV <*> fresh + where + freshVV = vv . Just <$> fresh + +instance Freshable m Integer => Freshable m RReft where + fresh = errorstar "fresh RReft" + true (U r _ s) = U <$> true r <*> return mempty <*> true s + refresh (U r _ s) = U <$> refresh r <*> return mempty <*> refresh s + +instance Freshable m Integer => Freshable m Strata where + fresh = (:[]) . SVar <$> fresh + true [] = fresh + true s = return s + refresh [] = fresh + refresh s = return s + +instance (Freshable m Integer, Freshable m r, Reftable r) => Freshable m (RRType r) where + fresh = errorstar "fresh RefType" + refresh = refreshRefType + true = trueRefType + +----------------------------------------------------------------------------------------------- +trueRefType :: (Freshable m Integer, Freshable m r, Reftable r) => RRType r -> m (RRType r) +----------------------------------------------------------------------------------------------- +trueRefType (RAllT α t) + = RAllT α <$> true t + +trueRefType (RAllP π t) + = RAllP π <$> true t + +trueRefType (RFun _ t t' _) + = rFun <$> fresh <*> true t <*> true t' + +trueRefType (RApp c ts rs r) + = RApp c <$> mapM true ts <*> mapM trueRef rs <*> true r + +trueRefType (RAppTy t t' _) + = RAppTy <$> true t <*> true t' <*> return mempty + +trueRefType (RVar a r) + = RVar a <$> true r + +trueRefType t + = return t + +trueRef (RProp s t) = RProp s <$> trueRefType t +trueRef _ = errorstar "trueRef: unexpected" + + +----------------------------------------------------------------------------------------------- +refreshRefType :: (Freshable m Integer, Freshable m r, Reftable r) => RRType r -> m (RRType r) +----------------------------------------------------------------------------------------------- +refreshRefType (RAllT α t) + = RAllT α <$> refresh t + +refreshRefType (RAllP π t) + = RAllP π <$> refresh t + +refreshRefType (RFun b t t' _) + | b == dummySymbol = rFun <$> fresh <*> refresh t <*> refresh t' + | otherwise = rFun b <$> refresh t <*> refresh t' + +refreshRefType (RApp rc ts rs r) + = RApp rc <$> mapM refresh ts <*> mapM refreshRef rs <*> refresh r + +refreshRefType (RVar a r) + = RVar a <$> refresh r + +refreshRefType (RAppTy t t' r) + = RAppTy <$> refresh t <*> refresh t' <*> refresh r + +refreshRefType t + = return t + +refreshRef (RProp s t) = RProp <$> mapM freshSym s <*> refreshRefType t +refreshRef _ = errorstar "refreshRef: unexpected" +freshSym (_, t) = (, t) <$> fresh + diff --git a/src/Language/Haskell/Liquid/GhcInterface.hs b/src/Language/Haskell/Liquid/GhcInterface.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GhcInterface.hs @@ -0,0 +1,582 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Language.Haskell.Liquid.GhcInterface ( + + -- * extract all information needed for verification + getGhcInfo + + -- * visitors + , CBVisitable (..) + ) where +import IdInfo +import InstEnv +import qualified Data.Foldable as F +import Bag (bagToList) +import ErrUtils +import Panic +import GHC hiding (Target) +import DriverPhases (Phase(..)) +import DriverPipeline (compileFile) +import Text.PrettyPrint.HughesPJ +import HscTypes hiding (Target) +import TidyPgm (tidyProgram) +import Literal +import CoreSyn + +import Var +import Name (getSrcSpan) +import CoreMonad (liftIO) +import DataCon +import qualified TyCon as TC +import HscMain +import Module +import Language.Haskell.Liquid.Desugar.HscMain (hscDesugarWithLoc) +import qualified Control.Exception as Ex + +import GHC.Paths (libdir) +import System.FilePath ( replaceExtension + , dropExtension + , takeFileName + , splitFileName + , combine + , dropFileName + , normalise) + +import DynFlags +import Control.Arrow (second) +import Control.Monad (filterM, foldM, zipWithM, when, forM, forM_, liftM, (<=<)) +import Control.DeepSeq +import Control.Applicative hiding (empty) +import Data.Monoid hiding ((<>)) +import Data.List (partition, intercalate, foldl', find, (\\), delete, nub) +import Data.Maybe (fromMaybe, catMaybes, maybeToList) +import qualified Data.HashSet as S +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T + +import System.Console.CmdArgs.Verbosity (whenLoud) +import System.Directory (removeFile, createDirectory, doesFileExist) +import Language.Fixpoint.Types hiding (Expr) +import Language.Fixpoint.Misc + +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.RefType +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.CmdLine (withPragmas) +import Language.Haskell.Liquid.Parse + +import Language.Fixpoint.Parse hiding (brackets, comma) +import Language.Fixpoint.Names +import Language.Fixpoint.Files + +import qualified Language.Haskell.Liquid.Measure as Ms + + +-------------------------------------------------------------------- +getGhcInfo :: Config -> FilePath -> IO (Either ErrorResult GhcInfo) +-------------------------------------------------------------------- +getGhcInfo cfg target = (Right <$> getGhcInfo' cfg target) + `Ex.catch` (\(e :: SourceError) -> handle e) + `Ex.catch` (\(e :: Error) -> handle e) + `Ex.catch` (\(e :: [Error]) -> handle e) + where + handle = return . Left . result + + +getGhcInfo' cfg0 target + = runGhc (Just libdir) $ do + liftIO $ cleanFiles target + addTarget =<< guessTarget target Nothing + (name,tgtSpec) <- liftIO $ parseSpec target + cfg <- liftIO $ withPragmas cfg0 target $ Ms.pragmas tgtSpec + let paths = idirs cfg + updateDynFlags cfg + liftIO $ whenLoud $ putStrLn ("paths = " ++ show paths) + let name' = ModName Target (getModName name) + impNames <- allDepNames <$> depanal [] False + impSpecs <- getSpecs (real cfg) (totality cfg) target paths impNames [Spec, Hs, LHs] + compileCFiles =<< liftIO (foldM (\c (f,_,s) -> withPragmas c f (Ms.pragmas s)) cfg impSpecs) + impSpecs' <- forM impSpecs $ \(f,n,s) -> do + when (not $ isSpecImport n) $ + addTarget =<< guessTarget f Nothing + return (n,s) + load LoadAllTargets + modguts <- getGhcModGuts1 target + hscEnv <- getSession + coreBinds <- liftIO $ anormalize (not $ nocaseexpand cfg) hscEnv modguts + let impVs = importVars coreBinds + let defVs = definedVars coreBinds + let useVs = readVars coreBinds + let letVs = letVars coreBinds + let derVs = derivedVars coreBinds $ mgi_is_dfun modguts + (spec, imps, incs) <- moduleSpec cfg coreBinds (impVs ++ defVs) letVs name' modguts tgtSpec impSpecs' + liftIO $ whenLoud $ putStrLn $ "Module Imports: " ++ show imps + hqualFiles <- moduleHquals modguts paths target imps incs + return $ GI hscEnv coreBinds derVs impVs letVs useVs hqualFiles imps incs spec + +derivedVars :: CoreProgram -> Maybe [DFunId] -> [Id] +derivedVars cbs (Just fds) = concatMap (derivedVs cbs) fds +derivedVars cbs Nothing = [] + +derivedVs :: CoreProgram -> DFunId -> [Id] +derivedVs cbs fd = concatMap bindersOf cbf ++ deps + where cbf = filter f cbs + + f (NonRec x _) = eqFd x + f (Rec xes ) = any eqFd (fst <$> xes) + eqFd x = varName x == varName fd + deps :: [Id] + deps = concatMap dep $ (unfoldingInfo . idInfo <$> concatMap bindersOf cbf) + + dep (DFunUnfolding _ _ e) = concatMap grapDep e + dep _ = [] + + grapDep :: CoreExpr -> [Id] + grapDep (Var x) = [x] + grapDep _ = [] + +updateDynFlags cfg + = do df <- getSessionDynFlags + let df' = df { importPaths = idirs cfg ++ importPaths df + , libraryPaths = idirs cfg ++ libraryPaths df + , includePaths = idirs cfg ++ includePaths df + , profAuto = ProfAutoCalls + , ghcLink = LinkInMemory + --FIXME: this *should* be HscNothing, but that prevents us from + -- looking up *unexported* names in another source module.. + , hscTarget = HscInterpreted -- HscNothing + , ghcMode = CompManager + -- prevent GHC from printing anything + , log_action = \_ _ _ _ _ -> return () + -- , verbosity = 3 + } `xopt_set` Opt_MagicHash + -- `gopt_set` Opt_Hpc + `gopt_set` Opt_ImplicitImportQualified + `gopt_set` Opt_PIC + (df'',_,_) <- parseDynamicFlags df' (map noLoc $ ghcOptions cfg) + setSessionDynFlags $ df'' -- {profAuto = ProfAutoAll} + +compileCFiles cfg + = do df <- getSessionDynFlags + setSessionDynFlags $ df { includePaths = nub $ idirs cfg ++ includePaths df + , importPaths = nub $ idirs cfg ++ importPaths df + , libraryPaths = nub $ idirs cfg ++ libraryPaths df } + hsc <- getSession + os <- mapM (\x -> liftIO $ compileFile hsc StopLn (x,Nothing)) (nub $ cFiles cfg) + df <- getSessionDynFlags + setSessionDynFlags $ df { ldInputs = map (FileOption "") os ++ ldInputs df } + + +mgi_namestring = moduleNameString . moduleName . mgi_module + +importVars = freeVars S.empty + +definedVars = concatMap defs + where + defs (NonRec x _) = [x] + defs (Rec xes) = map fst xes + + +------------------------------------------------------------------ +-- | Extracting CoreBindings From File --------------------------- +------------------------------------------------------------------ +getGhcModGuts1 :: FilePath -> Ghc MGIModGuts +getGhcModGuts1 fn = do + modGraph <- getModuleGraph + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + -- mod_guts <- modSummaryModGuts modSummary + mod_p <- parseModule modSummary + mod_guts <- coreModule <$> (desugarModuleWithLoc =<< typecheckModule (ignoreInline mod_p)) + let deriv = getDerivedDictionaries mod_guts mod_p + return $! (miModGuts (Just deriv) mod_guts) + Nothing -> exitWithPanic "Ghc Interface: Unable to get GhcModGuts" + + +getDerivedDictionaries cm mod = filter ((`elem` pdFuns) . shortPpr) dFuns + where hsmod = unLoc $ pm_parsed_source mod + decls = unLoc <$> hsmodDecls hsmod + tyClD = [d | TyClD d <- decls] + tyDec = filter isDataDecl tyClD + inst = mkInst <$> tyDec + mkInst x = (tcdLName x, dd_derivs $ tcdDataDefn x) + mkDic = \(x, y) -> "$f" ++ showPpr y ++ showPpr x + + pdFuns = mkDic <$> [(c, d) | (c, ds) <- inst, d <- F.concat ds] + dFuns = is_dfun <$> (instEnvElts $ mg_inst_env cm) + + shortPpr = symbolString . dropModuleNames . symbol + +-- Generates Simplified ModGuts (INLINED, etc.) but without SrcSpan +getGhcModGutsSimpl1 fn = do + modGraph <- getModuleGraph + case find ((== fn) . msHsFilePath) modGraph of + Just modSummary -> do + mod_guts <- coreModule `fmap` (desugarModule =<< typecheckModule =<< liftM ignoreInline (parseModule modSummary)) + hsc_env <- getSession + simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts + (cg,_) <- liftIO $ tidyProgram hsc_env simpl_guts + liftIO $ putStrLn "************************* CoreGuts ****************************************" + liftIO $ putStrLn (showPpr $ cg_binds cg) + return $! (miModGuts Nothing mod_guts) { mgi_binds = cg_binds cg } + Nothing -> error "GhcInterface : getGhcModGutsSimpl1" + +peepGHCSimple fn + = do z <- compileToCoreSimplified fn + liftIO $ putStrLn "************************* peepGHCSimple Core Module ************************" + liftIO $ putStrLn $ showPpr z + liftIO $ putStrLn "************************* peepGHCSimple Bindings ***************************" + liftIO $ putStrLn $ showPpr (cm_binds z) + errorstar "Done peepGHCSimple" + +cleanFiles :: FilePath -> IO () +-- deleteBinFilez fn = mapM_ (tryIgnore "delete binaries" . removeFileIfExists) +-- $ (fn `replaceExtension`) `fmap` exts +-- where +-- exts = ["hi", "o"] + +cleanFiles fn + = do forM_ bins (tryIgnore "delete binaries" . removeFileIfExists) + tryIgnore "create temp directory" $ createDirectory dir + where + bins = replaceExtension fn <$> ["hi", "o"] + dir = tempDirectory fn + + +removeFileIfExists f = doesFileExist f >>= (`when` removeFile f) + +-------------------------------------------------------------------------------- +-- | Desugaring (Taken from GHC, modified to hold onto Loc in Ticks) ----------- +-------------------------------------------------------------------------------- + +desugarModuleWithLoc :: TypecheckedModule -> Ghc DesugaredModule +desugarModuleWithLoc 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 } + +-------------------------------------------------------------------------------- +-- | Extracting Qualifiers ----------------------------------------------------- +-------------------------------------------------------------------------------- + +moduleHquals mg paths target imps incs + = do hqs <- specIncludes Hquals paths incs + hqs' <- moduleImports [Hquals] paths (mgi_namestring mg : imps) + hqs'' <- liftIO $ filterM doesFileExist [extFileName Hquals target] + let rv = sortNub $ hqs'' ++ hqs ++ (snd <$> hqs') + liftIO $ whenLoud $ putStrLn $ "Reading Qualifiers From: " ++ show rv + return rv + +-------------------------------------------------------------------------------- +-- | Extracting Specifications (Measures + Assumptions) ------------------------ +-------------------------------------------------------------------------------- + +moduleSpec cfg cbs vars defVars target mg tgtSpec impSpecs + = do addImports impSpecs + addContext $ IIModule $ moduleName $ mgi_module mg + env <- getSession + let specs = (target,tgtSpec):impSpecs + let imps = sortNub $ impNames ++ [ symbolString x + | (_,spec) <- specs + , x <- Ms.imports spec + ] + ghcSpec <- liftIO $ makeGhcSpec cfg target cbs vars defVars exports env specs + return (ghcSpec, imps, Ms.includes tgtSpec) + where + exports = mgi_exports mg + name = mgi_namestring mg + impNames = map (getModString.fst) impSpecs + addImports = mapM (addContext . IIDecl . qualImportDecl . getModName . fst) + +allDepNames = concatMap (map declNameString . ms_textual_imps) + +declNameString = moduleNameString . unLoc . ideclName . unLoc + +depNames = map fst . dep_mods . mgi_deps +dirImportNames = map moduleName . moduleEnvKeys . mgi_dir_imps +targetName = dropExtension . takeFileName +-- starName fn = combine dir ('*':f) where (dir, f) = splitFileName fn +starName = ("*" ++) + +patErrorName = "PatErr" +realSpecName = "Real" +notRealSpecName = "NotReal" + +getSpecs rflag tflag target paths names exts + = do fs' <- sortNub <$> moduleImports exts paths names + patSpec <- getPatSpec paths tflag + rlSpec <- getRealSpec paths rflag + let fs = patSpec ++ rlSpec ++ fs' + liftIO $ whenLoud $ putStrLn ("getSpecs: " ++ show fs) + transParseSpecs exts paths (S.singleton target) mempty (map snd fs) + +getPatSpec paths totalitycheck + | totalitycheck + = (map (patErrorName, )) . maybeToList <$> moduleFile paths patErrorName Spec + | otherwise + = return [] + +getRealSpec paths freal + | freal + = (map (realSpecName, )) . maybeToList <$> moduleFile paths realSpecName Spec + | otherwise + = (map (notRealSpecName, )) . maybeToList <$> moduleFile paths notRealSpecName Spec + +transParseSpecs _ _ _ specs [] + = return specs +transParseSpecs exts paths seenFiles specs newFiles + = do newSpecs <- liftIO $ mapM (\f -> addFst3 f <$> parseSpec f) newFiles + impFiles <- moduleImports exts paths $ specsImports newSpecs + let seenFiles' = seenFiles `S.union` (S.fromList newFiles) + let specs' = specs ++ map (third noTerm) newSpecs + let newFiles' = [f | (_,f) <- impFiles, not (f `S.member` seenFiles')] + transParseSpecs exts paths seenFiles' specs' newFiles' + where + specsImports ss = nub $ concatMap (map symbolString . Ms.imports . thd3) ss + noTerm spec = spec { Ms.decr=mempty, Ms.lazy=mempty, Ms.termexprs=mempty } + third f (a,b,c) = (a,b,f c) + +parseSpec :: FilePath -> IO (ModName, Ms.BareSpec) +parseSpec file + = do whenLoud $ putStrLn $ "parseSpec: " ++ file + either Ex.throw return . specParser file =<< readFile file + +specParser file str + | isExtFile Spec file = specSpecificationP file str + | isExtFile Hs file = hsSpecificationP file str + | isExtFile LHs file = lhsSpecificationP file str + | otherwise = exitWithPanic $ "SpecParser: Cannot Parse File " ++ file + +moduleImports :: GhcMonad m => [Ext] -> [FilePath] -> [String] -> m [(String, FilePath)] +moduleImports exts paths names + = liftM concat $ forM names $ \name -> do + map (name,) . catMaybes <$> mapM (moduleFile paths name) exts + +moduleFile :: GhcMonad m => [FilePath] -> String -> Ext -> m (Maybe FilePath) +moduleFile paths name ext + | ext `elem` [Hs, LHs] + = do mg <- getModuleGraph + case find ((==name) . moduleNameString . ms_mod_name) mg of + Nothing -> liftIO $ getFileInDirs (extModuleName name ext) paths + Just ms -> return $ normalise <$> ml_hs_file (ms_location ms) + | otherwise + = liftIO $ getFileInDirs (extModuleName name ext) paths + +isJust Nothing = False +isJust (Just a) = True + +--moduleImports ext paths names +-- = liftIO $ liftM catMaybes $ forM extNames (namePath paths) +-- where extNames = (`extModuleName` ext) <$> names +-- namePath paths fileName = getFileInDirs fileName paths + +--namePath_debug paths name +-- = do res <- getFileInDirs name paths +-- case res of +-- Just p -> putStrLn $ "namePath: name = " ++ name ++ " expanded to: " ++ (show p) +-- Nothing -> putStrLn $ "namePath: name = " ++ name ++ " not found in: " ++ (show paths) +-- return res + +specIncludes :: GhcMonad m => Ext -> [FilePath] -> [FilePath] -> m [FilePath] +specIncludes ext paths reqs + = do let libFile = extFileNameR ext $ symbolString preludeName + let incFiles = catMaybes $ reqFile ext <$> reqs + liftIO $ forM (libFile : incFiles) (`findFileInDirs` paths) + +reqFile ext s + | isExtFile ext s + = Just s + | otherwise + = Nothing + + +------------------------------------------------------------------------------ +-------------------------------- A CoreBind Visitor -------------------------- +------------------------------------------------------------------------------ + +-- TODO: syb-shrinkage + +class CBVisitable a where + freeVars :: S.HashSet Var -> a -> [Var] + readVars :: a -> [Var] + letVars :: a -> [Var] + literals :: a -> [Literal] + +instance CBVisitable [CoreBind] where + freeVars env cbs = (sortNub xs) \\ ys + where xs = concatMap (freeVars env) cbs + ys = concatMap bindings cbs + + readVars = concatMap readVars + letVars = concatMap letVars + literals = concatMap literals + +instance CBVisitable CoreBind where + freeVars env (NonRec x e) = freeVars (extendEnv env [x]) e + freeVars env (Rec xes) = concatMap (freeVars env') es + where (xs,es) = unzip xes + env' = extendEnv env xs + + readVars (NonRec _ e) = readVars e + readVars (Rec xes) = concat [x `delete` nubReadVars e |(x, e) <- xes] + where nubReadVars = sortNub . readVars + + letVars (NonRec x e) = x : letVars e + letVars (Rec xes) = xs ++ concatMap letVars es + where + (xs, es) = unzip xes + + literals (NonRec _ e) = literals e + literals (Rec xes) = concatMap literals $ map snd xes + +instance CBVisitable (Expr Var) where + freeVars = exprFreeVars + readVars = exprReadVars + letVars = exprLetVars + literals = exprLiterals + +exprFreeVars = go + where + go env (Var x) = if x `S.member` env then [] else [x] + go env (App e a) = (go env e) ++ (go env a) + go env (Lam x e) = go (extendEnv env [x]) e + go env (Let b e) = (freeVars env b) ++ (go (extendEnv env (bindings b)) e) + go env (Tick _ e) = go env e + go env (Cast e _) = go env e + go env (Case e x _ cs) = (go env e) ++ (concatMap (freeVars (extendEnv env [x])) cs) + go _ _ = [] + +exprReadVars = go + where + go (Var x) = [x] + go (App e a) = concatMap go [e, a] + go (Lam _ e) = go e + go (Let b e) = readVars b ++ go e + go (Tick _ e) = go e + go (Cast e _) = go e + go (Case e _ _ cs) = (go e) ++ (concatMap readVars cs) + go _ = [] + +exprLetVars = go + where + go (Var _) = [] + go (App e a) = concatMap go [e, a] + go (Lam x e) = x : go e + go (Let b e) = letVars b ++ go e + go (Tick _ e) = go e + go (Cast e _) = go e + go (Case e x _ cs) = x : go e ++ concatMap letVars cs + go _ = [] + +exprLiterals = go + where + go (Lit l) = [l] + go (App e a) = concatMap go [e, a] + go (Let b e) = literals b ++ go e + go (Lam _ e) = go e + go (Tick _ e) = go e + go (Cast e _) = go e + go (Case e _ _ cs) = (go e) ++ (concatMap literals cs) + go _ = [] + + +instance CBVisitable (Alt Var) where + freeVars env (a, xs, e) = freeVars env a ++ freeVars (extendEnv env xs) e + readVars (_,_, e) = readVars e + letVars (_,xs,e) = xs ++ letVars e + literals (c,_, e) = literals c ++ literals e + + +instance CBVisitable AltCon where + freeVars _ (DataAlt dc) = dataConImplicitIds dc + freeVars _ _ = [] + readVars _ = [] + letVars _ = [] + literals (LitAlt l) = [l] + literals _ = [] + + + +extendEnv = foldl' (flip S.insert) + +-- names = (map varName) . bindings +-- +bindings (NonRec x _) + = [x] +bindings (Rec xes ) + = map fst xes + +-------------------------------------------------------------------- +------ Strictness -------------------------------------------------- +-------------------------------------------------------------------- + +instance NFData Var +instance NFData SrcSpan + +instance PPrint GhcSpec where + pprint spec = (text "******* Target Variables ********************") + $$ (pprint $ tgtVars spec) + $$ (text "******* Type Signatures *********************") + $$ (pprintLongList $ tySigs spec) + $$ (text "******* Assumed Type Signatures *************") + $$ (pprintLongList $ asmSigs spec) + $$ (text "******* DataCon Specifications (Measure) ****") + $$ (pprintLongList $ ctors spec) + $$ (text "******* Measure Specifications **************") + $$ (pprintLongList $ meas spec) + +instance PPrint GhcInfo where + pprint info = (text "*************** Imports *********************") + $+$ (intersperse comma $ text <$> imports info) + $+$ (text "*************** Includes ********************") + $+$ (intersperse comma $ text <$> includes info) + $+$ (text "*************** Imported Variables **********") + $+$ (pprDoc $ impVars info) + $+$ (text "*************** Defined Variables ***********") + $+$ (pprDoc $ defVars info) + $+$ (text "*************** Specification ***************") + $+$ (pprint $ spec info) + $+$ (text "*************** Core Bindings ***************") + $+$ (pprint $ cbs info) + +instance Show GhcInfo where + show = showpp + +instance PPrint [CoreBind] where + pprint = pprDoc . tidyCBs + +instance PPrint TargetVars where + pprint AllVars = text "All Variables" + pprint (Only vs) = text "Only Variables: " <+> pprint vs + +------------------------------------------------------------------------ +-- 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") + . concatMap errMsgErrors + . bagToList + . srcErrorMessages + +errMsgErrors e = [ ErrGhc (errMsgSpan e) (pprint e)] + diff --git a/src/Language/Haskell/Liquid/GhcMisc.hs b/src/Language/Haskell/Liquid/GhcMisc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/GhcMisc.hs @@ -0,0 +1,382 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module contains a wrappers and utility functions for +-- accessing GHC module information. It should NEVER depend on +-- ANY module inside the Language.Haskell.Liquid.* tree. + +module Language.Haskell.Liquid.GhcMisc where + +import Debug.Trace + +import Avail (availsToNameSet) +import CoreSyn hiding (Expr) +import CostCentre +import FamInstEnv (FamInst) +import GHC hiding (L) +import HscTypes (Dependencies, ImportedMods, ModGuts(..)) +import Kind (superKind) +import NameSet (NameSet) +import SrcLoc (mkRealSrcLoc, mkRealSrcSpan, srcSpanFile, srcSpanFileName_maybe, srcSpanStartLine, srcSpanStartCol) + +import Language.Fixpoint.Misc (errorstar, stripParens) +import Text.Parsec.Pos (sourceName, sourceLine, sourceColumn, SourcePos, newPos) +import Language.Fixpoint.Types hiding (SESearch(..)) +import Name (mkInternalName, getSrcSpan, nameModule_maybe) +import Module (moduleNameFS) +import OccName (mkTyVarOcc, mkTcOcc) +import Unique +import Finder (findImportedModule, cannotFindModule) +import DynamicLoading +import ErrUtils +import Exception +import Panic (GhcException(..), throwGhcException) +import RnNames (gresFromAvails) +import HscMain +import HscTypes (HscEnv(..), FindResult(..), ModIface(..), lookupTypeHscEnv) +import FastString +import TcRnDriver +import OccName + + +import RdrName +import Type (liftedTypeKind, eqType) +import TypeRep +import Var +-- import TyCon (mkSuperKindTyCon) +import qualified TyCon as TC +import qualified DataCon as DC +import FastString (uniq, unpackFS, fsLit) +import Data.Char (isLower, isSpace) +import Data.Maybe +import Data.Monoid (mempty) +import Data.Hashable +import qualified Data.HashSet as S +import qualified Data.List as L +import Data.Aeson +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Unsafe as T +import Control.Applicative ((<$>), (<*>)) +import Control.Arrow (second) +import Control.Exception (assert, throw) +import Outputable (Outputable (..), text, ppr) +import qualified Outputable as Out +import DynFlags +-- import Language.Haskell.Liquid.Types + +-- import qualified Pretty as P +import qualified Text.PrettyPrint.HughesPJ as PJ + +----------------------------------------------------------------------- +--------------- Datatype For Holding GHC ModGuts ---------------------- +----------------------------------------------------------------------- + +data MGIModGuts = MI { + mgi_binds :: !CoreProgram + , mgi_module :: !Module + , mgi_deps :: !Dependencies + , mgi_dir_imps :: !ImportedMods + , mgi_rdr_env :: !GlobalRdrEnv + , mgi_tcs :: ![TyCon] + , mgi_fam_insts :: ![FamInst] + , mgi_exports :: !NameSet + , mgi_is_dfun :: !(Maybe [DFunId]) + } + +miModGuts dids mg = MI { + mgi_binds = mg_binds mg + , mgi_module = mg_module mg + , mgi_deps = mg_deps mg + , mgi_dir_imps = mg_dir_imps mg + , mgi_rdr_env = mg_rdr_env mg + , mgi_tcs = mg_tcs mg + , mgi_fam_insts = mg_fam_insts mg + , mgi_exports = availsToNameSet $ mg_exports mg + , mgi_is_dfun = dids + } + +----------------------------------------------------------------------- +--------------- Generic Helpers for Encoding Location ----------------- +----------------------------------------------------------------------- + +srcSpanTick :: Module -> SrcSpan -> Tickish a +srcSpanTick m loc + = ProfNote (AllCafsCC m loc) False True + +tickSrcSpan :: Outputable a => Tickish a -> SrcSpan +tickSrcSpan (ProfNote cc _ _) = cc_loc cc +tickSrcSpan z = noSrcSpan -- errorstar msg +-- where msg = "tickSrcSpan: unhandled tick: " ++ showPpr z + +----------------------------------------------------------------------- +--------------- Generic Helpers for Accessing GHC Innards ------------- +----------------------------------------------------------------------- + +stringTyVar :: String -> TyVar +stringTyVar s = mkTyVar name liftedTypeKind + where name = mkInternalName (mkUnique 'x' 24) occ noSrcSpan + occ = mkTyVarOcc s + +stringTyCon :: Char -> Int -> String -> TyCon +stringTyCon c n s = TC.mkKindTyCon name superKind + where + name = mkInternalName (mkUnique c n) occ noSrcSpan + occ = mkTcOcc s + +hasBaseTypeVar = isBaseType . varType + +-- same as Constraint isBase +isBaseType (TyVarTy _) = True +isBaseType (TyConApp _ ts) = all isBaseType ts +isBaseType (FunTy t1 t2) = isBaseType t1 && isBaseType t2 +isBaseType _ = False +validTyVar :: String -> Bool +validTyVar s@(c:_) = isLower c && all (not . isSpace) s +validTyVar _ = False + +tvId α = {- traceShow ("tvId: α = " ++ show α) $ -} showPpr α ++ show (varUnique α) + +tracePpr s x = trace ("\nTrace: [" ++ s ++ "] : " ++ showPpr x) x + +pprShow = text . show + + +tidyCBs = map unTick + +unTick (NonRec b e) = NonRec b (unTickExpr e) +unTick (Rec bs) = Rec $ map (second unTickExpr) bs + +unTickExpr (App e a) = App (unTickExpr e) (unTickExpr a) +unTickExpr (Lam b e) = Lam b (unTickExpr e) +unTickExpr (Let b e) = Let (unTick b) (unTickExpr e) +unTickExpr (Case e b t as) = Case (unTickExpr e) b t (map unTickAlt as) + where unTickAlt (a, b, e) = (a, b, unTickExpr e) +unTickExpr (Cast e c) = Cast (unTickExpr e) c +unTickExpr (Tick _ e) = unTickExpr e +unTickExpr x = x + +----------------------------------------------------------------------- +------------------ Generic Helpers for DataConstructors --------------- +----------------------------------------------------------------------- + +getDataConVarUnique v + | isId v && isDataConWorkId v = getUnique $ idDataCon v + | otherwise = getUnique v + + +newtype Loc = L (Int, Int) deriving (Eq, Ord, Show) + +instance Hashable Loc where + hashWithSalt i (L z) = hashWithSalt i z + +--instance (Uniquable a) => Hashable a where + +instance Hashable SrcSpan where + hashWithSalt i (UnhelpfulSpan s) = hashWithSalt i (uniq s) + hashWithSalt i (RealSrcSpan s) = hashWithSalt i (srcSpanStartLine s, srcSpanStartCol s, srcSpanEndCol s) + +instance Outputable a => Outputable (S.HashSet a) where + ppr = ppr . S.toList + +instance ToJSON RealSrcSpan where + toJSON sp = object [ "filename" .= f -- (unpackFS $ srcSpanFile sp) + , "startLine" .= l1 -- srcSpanStartLine sp + , "startCol" .= c1 -- srcSpanStartCol sp + , "endLine" .= l2 -- srcSpanEndLine sp + , "endCol" .= c2 -- srcSpanEndCol sp + ] + where + (f, l1, c1, l2, c2) = unpackRealSrcSpan sp + +unpackRealSrcSpan rsp = (f, l1, c1, l2, c2) + where + f = unpackFS $ srcSpanFile rsp + l1 = srcSpanStartLine rsp + c1 = srcSpanStartCol rsp + l2 = srcSpanEndLine rsp + c2 = srcSpanEndCol rsp + + +instance FromJSON RealSrcSpan where + parseJSON (Object v) = realSrcSpan <$> v .: "filename" + <*> v .: "startLine" + <*> v .: "startCol" + <*> v .: "endLine" + <*> v .: "endCol" + parseJSON _ = mempty + +realSrcSpan f l1 c1 l2 c2 = mkRealSrcSpan loc1 loc2 + where + loc1 = mkRealSrcLoc (fsLit f) l1 c1 + loc2 = mkRealSrcLoc (fsLit f) l2 c2 + + + +instance ToJSON SrcSpan where + toJSON (RealSrcSpan rsp) = object [ "realSpan" .= True, "spanInfo" .= rsp ] + toJSON (UnhelpfulSpan _) = object [ "realSpan" .= False ] + +instance FromJSON SrcSpan where + parseJSON (Object v) = do tag <- v .: "realSpan" + case tag of + False -> return noSrcSpan + True -> RealSrcSpan <$> v .: "spanInfo" + parseJSON _ = mempty + + +------------------------------------------------------- + +toFixSDoc = PJ.text . PJ.render . toFix +sDocDoc = PJ.text . showSDoc +pprDoc = sDocDoc . ppr + +-- Overriding Outputable functions because they now require DynFlags! +showPpr = Out.showPpr unsafeGlobalDynFlags +showSDoc = Out.showSDoc unsafeGlobalDynFlags +showSDocDump = Out.showSDocDump unsafeGlobalDynFlags + +typeUniqueString = {- ("sort_" ++) . -} showSDocDump . ppr + +instance Fixpoint Var where + toFix = pprDoc + +instance Fixpoint Name where + toFix = pprDoc + +instance Fixpoint Type where + toFix = pprDoc + +instance Show Name where + show = showPpr + +instance Show Var where + show = showPpr + +instance Show Class where + show = showPpr + +instance Show TyCon where + show = showPpr + +sourcePosSrcSpan :: SourcePos -> SrcSpan +sourcePosSrcSpan = srcLocSpan . sourcePosSrcLoc + +sourcePosSrcLoc :: SourcePos -> SrcLoc +sourcePosSrcLoc p = mkSrcLoc (fsLit file) line col + where + file = sourceName p + line = sourceLine p + col = sourceColumn p + +srcSpanSourcePos :: SrcSpan -> SourcePos +srcSpanSourcePos (UnhelpfulSpan _) = dummyPos "LH.GhcMisc.srcSpanSourcePos" +srcSpanSourcePos (RealSrcSpan s) = realSrcSpanSourcePos s + +srcSpanFilename = maybe "" unpackFS . srcSpanFileName_maybe +srcSpanStartLoc l = L (srcSpanStartLine l, srcSpanStartCol l) +srcSpanEndLoc l = L (srcSpanEndLine l, srcSpanEndCol l) +oneLine l = srcSpanStartLine l == srcSpanEndLine l +lineCol l = (srcSpanStartLine l, srcSpanStartCol l) + +realSrcSpanSourcePos :: RealSrcSpan -> SourcePos +realSrcSpanSourcePos s = newPos file line col + where + file = unpackFS $ srcSpanFile s + line = srcSpanStartLine s + col = srcSpanStartCol s + +getSourcePos = srcSpanSourcePos . getSrcSpan + + +collectArguments n e = if length xs > n then take n xs else xs + where (vs', e') = collectValBinders' $ snd $ collectTyBinders e + vs = fst $ collectValBinders $ ignoreLetBinds e' + xs = vs' ++ vs + +collectValBinders' expr = go [] expr + where + go tvs (Lam b e) | isTyVar b = go tvs e + go tvs (Lam b e) | isId b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +ignoreLetBinds e@(Let (NonRec x xe) e') + = ignoreLetBinds e' +ignoreLetBinds e + = e + +isDictionary x = L.isPrefixOf "$d" (showPpr x) +isInternal x = L.isPrefixOf "$" (showPpr x) + + +instance Hashable Var where + hashWithSalt = uniqueHash + +instance Hashable TyCon where + hashWithSalt = uniqueHash + +uniqueHash i = hashWithSalt i . getKey . getUnique + +-- slightly modified version of DynamicLoading.lookupRdrNameInModule +lookupRdrName :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) +lookupRdrName hsc_env mod_name rdr_name = do + -- First find the package the module resides in by searching exposed packages and home modules + found_module <- findImportedModule hsc_env mod_name Nothing + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_iface) <- getModuleInterface hsc_env mod + case mb_iface of + Just iface -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name + , is_qual = False, is_dloc = noSrcSpan } + provenance = Imported [ImpSpec decl_spec ImpAll] + env = case mi_globals iface of + Nothing -> mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface)) + Just e -> e + case lookupGRE_RdrName rdr_name env of + [gre] -> return (Just (gre_name gre)) + [] -> return Nothing + _ -> Out.panic "lookupRdrNameInModule" + Nothing -> throwCmdLineErrorS dflags $ Out.hsep [Out.ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where dflags = hsc_dflags hsc_env + throwCmdLineErrorS dflags = throwCmdLineError . Out.showSDoc dflags + throwCmdLineError = throwGhcException . CmdLineError + + +addContext m = getContext >>= setContext . (m:) + +qualImportDecl mn = (simpleImportDecl mn) { ideclQualified = True } + +ignoreInline x = x {pm_parsed_source = go <$> pm_parsed_source x} + where go x = x {hsmodDecls = filter go' $ hsmodDecls x} + go' x | SigD (InlineSig _ _) <- unLoc x = False + | otherwise = True + +symbolTyCon x i n = stringTyCon x i (symbolString n) +symbolTyVar n = stringTyVar (symbolString n) + +instance Symbolic TyCon where + symbol = symbol . qualifiedNameSymbol . getName + +instance Symbolic Name where + symbol = symbol . showPpr -- qualifiedNameSymbol + +qualifiedNameSymbol n = symbol $ + case nameModule_maybe n of + Nothing -> occNameFS (getOccName n) + Just m -> concatFS [moduleNameFS (moduleName m), fsLit ".", occNameFS (getOccName n)] + +instance Symbolic FastString where + symbol = symbol . fastStringText + +fastStringText = T.decodeUtf8 . fastStringToByteString +symbolFastString = T.unsafeDupablePerformIO . mkFastStringByteString . T.encodeUtf8 . symbolText diff --git a/src/Language/Haskell/Liquid/Measure.hs b/src/Language/Haskell/Liquid/Measure.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Measure.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Haskell.Liquid.Measure ( + Spec (..) + , BareSpec + , MSpec (..) + , mkM, mkMSpec, mkMSpec' + , qualifySpec + , mapTy + , dataConTypes + , defRefType + ) where + +import GHC hiding (Located) +import Var +import qualified Outputable as O +import Text.PrettyPrint.HughesPJ hiding (first) +import Text.Printf (printf) +import DataCon +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Monoid hiding ((<>)) +import Data.List (foldl1', union, nub) +import Data.Either (partitionEithers) +import Data.Bifunctor +import Data.Text (Text) +import Control.Applicative ((<$>)) +import Control.Exception (assert) + +import Language.Fixpoint.Misc +import Language.Fixpoint.Types hiding (Def, R) +import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.Types hiding (GhcInfo(..), GhcSpec (..)) +import Language.Haskell.Liquid.RefType + +-- MOVE TO TYPES +type BareSpec = Spec BareType LocSymbol + +data Spec ty bndr = Spec { + measures :: ![Measure ty bndr] -- ^ User-defined properties for ADTs + , asmSigs :: ![(LocSymbol, ty)] -- ^ Assumed (unchecked) types + , sigs :: ![(LocSymbol, ty)] -- ^ Imported functions and types + , localSigs :: ![(LocSymbol, ty)] -- ^ Local type signatures + , invariants :: ![Located ty] -- ^ Data type invariants + , ialiases :: ![(Located ty, Located ty)] -- ^ Data type invariants to be checked + , imports :: ![Symbol] -- ^ Loaded spec module names + , dataDecls :: ![DataDecl] -- ^ Predicated data definitions + , includes :: ![FilePath] -- ^ Included qualifier files + , aliases :: ![RTAlias Symbol BareType] -- ^ RefType aliases + , paliases :: ![RTAlias Symbol Pred] -- ^ Refinement/Predicate aliases + , embeds :: !(TCEmb (LocSymbol)) -- ^ GHC-Tycon-to-fixpoint Tycon map + , qualifiers :: ![Qualifier] -- ^ Qualifiers in source/spec files + , decr :: ![(LocSymbol, [Int])] -- ^ Information on decreasing arguments + , lvars :: ![(LocSymbol)] -- ^ Variables that should be checked in the environment they are used + , lazy :: !(S.HashSet LocSymbol) -- ^ Ignore Termination Check in these Functions + , 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 + , classes :: ![RClass ty] -- ^ Refined Type-Classes + , termexprs :: ![(LocSymbol, [Expr])] -- ^ Terminating Conditions for functions + } + + +-- MOVE TO TYPES +data MSpec ty ctor = MSpec { + ctorMap :: M.HashMap Symbol [Def ctor] + , measMap :: M.HashMap LocSymbol (Measure ty ctor) + , cmeasMap :: M.HashMap LocSymbol (Measure ty ()) + , imeas :: ![Measure ty ctor] + } + + +instance (Show ty, Show ctor, PPrint ctor, PPrint ty) => Show (MSpec ty ctor) where + show (MSpec ct m cm im) + = "\nMSpec:\n" ++ + "\nctorMap:\t " ++ show ct ++ + "\nmeasMap:\t " ++ show m ++ + "\ncmeasMap:\t " ++ show cm ++ + "\nimeas:\t " ++ show im ++ + "\n" + +instance Eq ctor => Monoid (MSpec ty ctor) where + mempty = MSpec M.empty M.empty M.empty [] + + (MSpec c1 m1 cm1 im1) `mappend` (MSpec c2 m2 cm2 im2) + | null dups + = MSpec (M.unionWith (++) c1 c2) (m1 `M.union` m2) + (cm1 `M.union` cm2) (im1 ++ im2) + | otherwise + = errorstar $ err (head dups) + where dups = [(k1, k2) | k1 <- M.keys m1 , k2 <- M.keys m2, val k1 == val k2] + err (k1, k2) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp k1) (showpp $ map loc [k1, k2]) + +qualifySpec name sp = sp { sigs = [ (tx x, t) | (x, t) <- sigs sp] + , asmSigs = [ (tx x, t) | (x, t) <- asmSigs sp] +-- , termexprs = [ (tx x, es) | (x, es) <- termexprs sp] + } + where + tx = fmap (qualifySymbol name) + +mkM :: LocSymbol -> ty -> [Def bndr] -> Measure ty bndr +mkM name typ eqns + | all ((name ==) . measure) eqns + = M name typ eqns + | otherwise + = errorstar $ "invalid measure definition for " ++ (show name) + +-- mkMSpec :: [Measure ty LocSymbol] -> [Measure ty ()] -> [Measure ty LocSymbol] +-- -> MSpec ty LocSymbol + +mkMSpec' ms = MSpec cm mm M.empty [] + where + cm = groupMap (symbol . ctor) $ concatMap eqns ms + mm = M.fromList [(name m, m) | m <- ms ] + +mkMSpec ms cms ims = MSpec cm mm cmm ims + where + cm = groupMap (val . ctor) $ concatMap eqns (ms'++ims) + mm = M.fromList [(name m, m) | m <- ms' ] + cmm = M.fromList [(name m, m) | m <- cms ] + ms' = checkDuplicateMeasure ms + -- ms' = checkFail "Duplicate Measure Definition" (distinct . fmap name) ms + +checkDuplicateMeasure ms + = case M.toList dups of + [] -> ms + mms -> errorstar $ concatMap err mms + where + gms = group [(name m , m) | m <- ms] + dups = M.filter ((1 <) . length) gms + err (m,ms) = printf "\nDuplicate Measure Definitions for %s\n%s" (showpp m) (showpp $ map (loc . name) ms) + + + + +-- MOVE TO TYPES +instance Monoid (Spec ty bndr) where + mappend s1 s2 + = Spec { measures = measures s1 ++ measures s2 + , asmSigs = asmSigs s1 ++ asmSigs s2 + , sigs = sigs s1 ++ sigs s2 + , localSigs = localSigs s1 ++ localSigs s2 + , invariants = invariants s1 ++ invariants s2 + , ialiases = ialiases s1 ++ ialiases s2 + , imports = sortNub $ imports s1 ++ imports s2 + , dataDecls = dataDecls s1 ++ dataDecls s2 + , includes = sortNub $ includes s1 ++ includes s2 + , aliases = aliases s1 ++ aliases s2 + , paliases = paliases s1 ++ paliases s2 + , embeds = M.union (embeds s1) (embeds s2) + , qualifiers = qualifiers s1 ++ qualifiers s2 + , decr = decr s1 ++ decr s2 + , lvars = lvars s1 ++ lvars s2 + , lazy = S.union (lazy s1) (lazy s2) + , pragmas = pragmas s1 ++ pragmas s2 + , cmeasures = cmeasures s1 ++ cmeasures s2 + , imeasures = imeasures s1 ++ imeasures s2 + , classes = classes s1 ++ classes s1 + , termexprs = termexprs s1 ++ termexprs s2 + } + + mempty + = Spec { measures = [] + , asmSigs = [] + , sigs = [] + , localSigs = [] + , invariants = [] + , ialiases = [] + , imports = [] + , dataDecls = [] + , includes = [] + , aliases = [] + , paliases = [] + , embeds = M.empty + , qualifiers = [] + , decr = [] + , lvars = [] + , lazy = S.empty + , pragmas = [] + , cmeasures = [] + , imeasures = [] + , classes = [] + , termexprs = [] + } + +-- MOVE TO TYPES +instance Functor Def where + fmap f def = def { ctor = f (ctor def) } + +-- MOVE TO TYPES +instance Functor (Measure t) where + fmap f (M n s eqs) = M n s (fmap (fmap f) eqs) + +instance Functor CMeasure where + fmap f (CM n t) = CM n (f t) + +-- MOVE TO TYPES +instance Functor (MSpec t) where + fmap f (MSpec c m cm im) = MSpec (fc c) (fm m) cm (fmap (fmap f) im) + where fc = fmap $ fmap $ fmap f + fm = fmap $ fmap f + +-- MOVE TO TYPES +instance Bifunctor Measure where + first f (M n s eqs) = M n (f s) eqs + second f (M n s eqs) = M n s (fmap f <$> eqs) + +-- MOVE TO TYPES +instance Bifunctor MSpec where + first f (MSpec c m cm im) = MSpec c (fmap (first f) m) (fmap (first f) cm) (fmap (first f) im) + second = fmap + +-- MOVE TO TYPES +instance Bifunctor Spec where + first f s + = s { measures = first f <$> (measures s) + , asmSigs = second f <$> (asmSigs s) + , sigs = second f <$> (sigs s) + , localSigs = second f <$> (localSigs s) + , invariants = fmap f <$> (invariants s) + , ialiases = fmapP f <$> (ialiases s) + , cmeasures = first f <$> (cmeasures s) + , imeasures = first f <$> (imeasures s) + , classes = fmap f <$> (classes s) + } + where fmapP f (x, y) = (fmap f x, fmap f y) + + second f s + = s { measures = fmap (second f) (measures s) + , imeasures = fmap (second f) (imeasures s) + } + +-- MOVE TO TYPES +instance PPrint Body where + pprint (E e) = pprint e + pprint (P p) = pprint p + pprint (R v p) = braces (pprint v <+> text "|" <+> pprint p) + +-- instance PPrint a => Fixpoint (PPrint a) where +-- toFix (BDc c) = toFix c +-- toFix (BTup n) = parens $ toFix n + +-- MOVE TO TYPES +instance PPrint a => PPrint (Def a) where + pprint (Def m c bs body) = pprint m <> text " " <> cbsd <> text " = " <> pprint body + where cbsd = parens (pprint c <> hsep (pprint `fmap` bs)) + +-- MOVE TO TYPES +instance (PPrint t, PPrint a) => PPrint (Measure t a) where + pprint (M n s eqs) = pprint n <> text " :: " <> pprint s + $$ vcat (pprint `fmap` eqs) + +-- MOVE TO TYPES +instance (PPrint t, PPrint a) => PPrint (MSpec t a) where + pprint = vcat . fmap pprint . fmap snd . M.toList . measMap + +-- MOVE TO TYPES +instance PPrint (Measure t a) => Show (Measure t a) where + show = showpp + +instance PPrint t => PPrint (CMeasure t) where + pprint (CM n s) = pprint n <> text " :: " <> pprint s + +instance PPrint (CMeasure t) => Show (CMeasure t) where + show = showpp + +-- MOVE TO TYPES +mapTy :: (tya -> tyb) -> Measure tya c -> Measure tyb c +mapTy f (M n ty eqs) = M n (f ty) eqs + +dataConTypes :: MSpec RefType DataCon -> ([(Var, RefType)], [(LocSymbol, RefType)]) +dataConTypes s = (ctorTys, measTys) + where + measTys = [(name m, sort m) | m <- M.elems (measMap s) ++ imeas s] + ctorTys = concatMap mkDataConIdsTy [(defsVar ds, defsTy ds) + | (_, ds) <- M.toList (ctorMap s) + ] + defsTy = foldl1' meet . fmap defRefType + defsVar = ctor . safeHead "defsVar" + +defRefType :: Def DataCon -> RefType +defRefType (Def f dc xs body) = mkArrow as [] [] xts t' + where + as = RTV <$> dataConUnivTyVars dc + xts = safeZip msg xs $ ofType `fmap` dataConOrigArgTys dc + t' = refineWithCtorBody dc f body t + t = ofType $ dataConOrigResTy dc + msg = "defRefType dc = " ++ showPpr dc + + +refineWithCtorBody dc f body t = + case stripRTypeBase t of + Just (Reft (v, _)) -> + strengthen t $ Reft (v, [RConc $ bodyPred (EApp f [eVar v]) body]) + Nothing -> + errorstar $ "measure mismatch " ++ showpp f ++ " on con " ++ showPpr dc + + +bodyPred :: Expr -> Body -> Pred +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) + + diff --git a/src/Language/Haskell/Liquid/Misc.hs b/src/Language/Haskell/Liquid/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Misc.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TupleSections #-} + +module Language.Haskell.Liquid.Misc where + +import Control.Applicative +import System.FilePath +import qualified Data.Text as T + +import Language.Fixpoint.Misc (errorstar) +import Language.Fixpoint.Types + +import Paths_liquidhaskell + +safeIndex err n ls + | n >= length ls + = errorstar err + | otherwise + = ls !! n + +(!?) :: [a] -> Int -> Maybe a +[] !? _ = Nothing +(x:_) !? 0 = Just x +(_:xs) !? n = xs !? (n-1) + +safeFromJust err (Just x) = x +safeFromJust err _ = errorstar err + +addFst3 a (b, c) = (a, b, c) +dropFst3 (_, x, y) = (x, y) +dropThd3 (x, y, _) = (x, y) + +replaceN n y ls = [if i == n then y else x | (x, i) <- zip ls [0..]] + +fourth4 (_,_,_,x) = x +third4 (_,_,x,_) = x + +mapSndM f (x, y) = return . (x,) =<< f y + +firstM f (a,b) = (,b) <$> f a +secondM f (a,b) = (a,) <$> f b + +first3M f (a,b,c) = (,b,c) <$> f a +second3M f (a,b,c) = (a,,c) <$> f b +third3M f (a,b,c) = (a,b,) <$> f c + +third3 f (a,b,c) = (a,b,f c) + +zip4 (x1:xs1) (x2:xs2) (x3:xs3) (x4:xs4) = (x1, x2, x3, x4) : (zip4 xs1 xs2 xs3 xs4) +zip4 _ _ _ _ = [] + +getIncludeDir = dropFileName <$> getDataFileName "include/Prelude.spec" +getCssPath = getDataFileName "syntax/liquid.css" +getHqBotPath = getDataFileName "include/Bot.hquals" + +safeZipWithError msg (x:xs) (y:ys) = (x,y) : safeZipWithError msg xs ys +safeZipWithError _ [] [] = [] +safeZipWithError msg _ _ = errorstar msg + +mapNs ns f xs = foldl (\xs n -> mapN n f xs) xs ns + +mapN 0 f (x:xs) = f x : xs +mapN n f (x:xs) = x : mapN (n-1) f xs +mapN _ _ [] = [] + + + +pad _ f [] ys = (f <$> ys, ys) +pad _ f xs [] = (xs, f <$> xs) +pad msg f xs ys + | nxs == nys = (xs, ys) + | otherwise = errorstar $ "pad: " ++ msg + where + nxs = length xs + nys = length ys + + diff --git a/src/Language/Haskell/Liquid/Parse.hs b/src/Language/Haskell/Liquid/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Parse.hs @@ -0,0 +1,863 @@ +{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances, UndecidableInstances, TypeSynonymInstances, TupleSections, OverloadedStrings #-} + +module Language.Haskell.Liquid.Parse + (hsSpecificationP, lhsSpecificationP, specSpecificationP) + where + +import Control.Monad +import Text.Parsec +import Text.Parsec.Error ( messageString + , errorMessages + , newErrorMessage + , errorPos + , Message (..)) +import Text.Parsec.Pos (newPos) + +import qualified Text.Parsec.Token as Token +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Interned + +import Control.Applicative ((<$>), (<*), (<*>)) +import Data.Char (toLower, isLower, isSpace, isAlpha) +import Data.List (foldl', partition) +import Data.Monoid (mempty) + +import GHC (mkModuleName, ModuleName) +import Text.PrettyPrint.HughesPJ (text) + +import Language.Preprocessor.Unlit (unlit) + +import Language.Fixpoint.Types hiding (Def, R) + +import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.Misc +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.RefType +import qualified Language.Haskell.Liquid.Measure as Measure +import Language.Fixpoint.Names (listConName, hpropConName, propConName, tupConName, headSym) +import Language.Fixpoint.Misc hiding (dcolon, dot) +import Language.Fixpoint.Parse hiding (angles) + +---------------------------------------------------------------------------- +-- Top Level Parsing API --------------------------------------------------- +---------------------------------------------------------------------------- + +------------------------------------------------------------------------------- +hsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) +------------------------------------------------------------------------------- + +hsSpecificationP = parseWithError $ do + name <- try (lookAhead $ skipMany (commentP >> spaces) + >> reserved "module" >> symbolP) + <|> return "Main" + liftM (mkSpec (ModName SrcImport $ mkModuleName $ symbolString name)) $ specWraps specP + +------------------------------------------------------------------------------- +lhsSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) +------------------------------------------------------------------------------- + +lhsSpecificationP sn s = hsSpecificationP sn $ unlit sn s + +commentP = simpleComment (string "{-") (string "-}") + <|> simpleComment (string "--") newlineP + <|> simpleComment (string "\\") newlineP + <|> simpleComment (string "#") newlineP + +simpleComment open close = open >> manyTill anyChar (try close) + +newlineP = try (string "\r\n") <|> string "\n" <|> string "\r" + + +-- | Used to parse .spec files + +-------------------------------------------------------------------------- +specSpecificationP :: SourceName -> String -> Either Error (ModName, Measure.BareSpec) +-------------------------------------------------------------------------- +specSpecificationP = parseWithError specificationP + +specificationP :: Parser (ModName, Measure.BareSpec) +specificationP + = do reserved "module" + reserved "spec" + name <- symbolP + reserved "where" + xs <- grabs (specP <* whiteSpace) + return $ mkSpec (ModName SpecImport $ mkModuleName $ symbolString name) xs + +--------------------------------------------------------------------------- +parseWithError :: Parser a -> SourceName -> String -> Either Error a +--------------------------------------------------------------------------- +parseWithError parser f s + = case runParser (remainderP (whiteSpace >> parser)) 0 f s of + Left e -> Left $ parseErrorError f e + Right (r, "", _) -> Right $ r + Right (_, rem, _) -> Left $ parseErrorError f $ remParseError f s rem + +--------------------------------------------------------------------------- +parseErrorError :: SourceName -> ParseError -> Error +--------------------------------------------------------------------------- +parseErrorError f e = ErrParse sp msg lpe + where + pos = errorPos e + sp = sourcePosSrcSpan pos + msg = text $ "Error Parsing Specification from: " ++ f + lpe = LPE pos (eMsgs e) + eMsgs = fmap messageString . errorMessages + +--------------------------------------------------------------------------- +remParseError :: SourceName -> String -> String -> ParseError +--------------------------------------------------------------------------- +remParseError f s r = newErrorMessage msg $ newPos f line col + where + msg = Message "Leftover while parsing" + (line, col) = remLineCol s r + +remLineCol :: String -> String -> (Int, Int) +remLineCol src rem = (line, col) + where + line = 1 + srcLine - remLine + srcLine = length srcLines + remLine = length remLines + col = srcCol - remCol + srcCol = length $ srcLines !! (line - 1) + remCol = length $ remLines !! 0 + srcLines = lines $ src + remLines = lines $ rem + + + +---------------------------------------------------------------------------------- +-- Lexer Tokens ------------------------------------------------------------------ +---------------------------------------------------------------------------------- + +dot = Token.dot lexer +angles = Token.angles lexer +stringLiteral = Token.stringLiteral lexer + +---------------------------------------------------------------------------------- +-- BareTypes --------------------------------------------------------------------- +---------------------------------------------------------------------------------- + +-- | The top-level parser for "bare" refinement types. If refinements are +-- not supplied, then the default "top" refinement is used. + +bareTypeP :: Parser BareType + +bareTypeP + = try bareAllP + <|> bareAllS + <|> bareAllExprP + <|> bareExistsP + <|> try bareFunP + <|> bareAtomP (refBindP bindP) + <|> try (angles (do t <- parens $ bareTypeP + p <- monoPredicateP + return $ t `strengthen` (U mempty p mempty))) + +bareArgP vv + = bareAtomP (refDefP vv) + <|> parens bareTypeP + +bareAtomP ref + = ref refasHoleP bbaseP + <|> holeP + <|> try (dummyP (bbaseP <* spaces)) + +holeP = reserved "_" >> spaces >> return (RHole $ uTop $ Reft ("VV", [hole])) +holeRefP = reserved "_" >> spaces >> return (RHole . uTop) +refasHoleP = refasP <|> (reserved "_" >> return [hole]) + +bbaseP :: Parser (Reft -> BareType) +bbaseP + = holeRefP + <|> liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP + <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP + <|> try (liftM2 bAppTy lowerIdP (sepBy1 bareTyArgP blanks)) + <|> try (liftM3 bRVar lowerIdP stratumP monoPredicateP) + <|> liftM5 bCon locUpperIdP stratumP predicatesP (sepBy bareTyArgP blanks) mmonoPredicateP + +stratumP :: Parser Strata +stratumP + = do reserved "^" + bstratumP + <|> return mempty + +bstratumP + = ((:[]) . SVar) <$> symbolP + +bbaseNoAppP :: Parser (Reft -> BareType) +bbaseNoAppP + = liftM2 bLst (brackets (maybeP bareTypeP)) predicatesP + <|> liftM2 bTup (parens $ sepBy bareTypeP comma) predicatesP + <|> try (liftM5 bCon locUpperIdP stratumP predicatesP (return []) (return mempty)) + <|> liftM3 bRVar lowerIdP stratumP monoPredicateP + +maybeP p = liftM Just p <|> return Nothing + +bareTyArgP + = -- try (RExprArg . expr <$> binderP) <|> + try (RExprArg . expr <$> integer) + <|> try (braces $ RExprArg <$> exprP) + <|> try bareAtomNoAppP + <|> try (parens bareTypeP) + +bareAtomNoAppP + = refP bbaseNoAppP + <|> try (dummyP (bbaseNoAppP <* spaces)) + +bareAllExprP + = do reserved "forall" + zs <- brackets $ sepBy1 exBindP comma + dot + t <- bareTypeP + return $ foldr (uncurry RAllE) t zs + +bareExistsP + = do reserved "exists" + zs <- brackets $ sepBy1 exBindP comma + dot + t <- bareTypeP + return $ foldr (uncurry REx) t zs + +exBindP + = do b <- binderP <* colon + t <- bareArgP b + return (b,t) + +bareAllS + = do reserved "forall" + ss <- (angles $ sepBy1 symbolP comma) + dot + t <- bareTypeP + return $ foldr RAllS t ss + +bareAllP + = do reserved "forall" + as <- many tyVarIdP + ps <- predVarDefsP + dot + t <- bareTypeP + return $ foldr RAllT (foldr RAllP t ps) as + +tyVarIdP :: Parser Symbol +tyVarIdP = symbol <$> condIdP alphanums (isLower . head) + where alphanums = ['a'..'z'] ++ ['0'..'9'] + +predVarDefsP + = try (angles $ sepBy1 predVarDefP comma) + <|> return [] + +predVarDefP + = bPVar <$> predVarIdP <*> dcolon <*> predVarTypeP + +predVarIdP + = symbol <$> tyVarIdP + +bPVar p _ xts = PV p (PVProp τ) dummySymbol τxs + where + (_, τ) = safeLast "bPVar last" xts + τxs = [ (τ, x, EVar x) | (x, τ) <- init xts ] + +predVarTypeP :: Parser [(Symbol, BSort)] +predVarTypeP = bareTypeP >>= either parserFail return . mkPredVarType + +mkPredVarType t + | isOk = Right $ zip xs ts + | otherwise = Left err + where + isOk = isPropBareType tOut || isHPropBareType tOut + tOut = ty_res trep + trep = toRTypeRep t + xs = ty_binds trep + ts = toRSort <$> ty_args trep + err = "Predicate Variable with non-Prop output sort: " ++ showpp t + +-- = do t <- bareTypeP +-- let trep = toRTypeRep t +-- if isPropBareType $ ty_res trep +-- then return $ zip (ty_binds trep) (toRSort <$> (ty_args trep)) +-- else parserFail $ "Predicate Variable with non-Prop output sort: " ++ showpp t + + +xyP lP sepP rP + = liftM3 (\x _ y -> (x, y)) lP (spaces >> sepP) rP + +data ArrowSym = ArrowFun | ArrowPred + +arrowP + = (reserved "->" >> return ArrowFun) + <|> (reserved "=>" >> return ArrowPred) + +positionNameP = dummyNamePos <$> getPosition + +dummyNamePos pos = "dummy." ++ name ++ ['.'] ++ line ++ ['.'] ++ col + where + name = san <$> sourceName pos + line = show $ sourceLine pos + col = show $ sourceColumn pos + san '/' = '.' + san c = toLower c + +bareFunP + = do b <- try bindP <|> dummyBindP + t1 <- bareArgP b + a <- arrowP + t2 <- bareTypeP + return $ bareArrow b t1 a t2 + +dummyBindP = tempSymbol "db" <$> freshIntP + +bbindP = lowerIdP <* dcolon + +bareArrow b t1 ArrowFun t2 + = rFun b t1 t2 +bareArrow _ t1 ArrowPred t2 + = foldr (rFun dummySymbol) t2 (getClasses t1) + + +isPropBareType = isPrimBareType propConName +isHPropBareType = isPrimBareType hpropConName +isPrimBareType n (RApp tc [] _ _) = val tc == n +isPrimBareType _ _ = False + + + +getClasses (RApp tc ts _ _) + | isTuple tc + = getClass `fmap` ts +getClasses t + = [getClass t] +getClass (RApp c ts _ _) + = RCls c ts +getClass t + = errorstar $ "Cannot convert " ++ (show t) ++ " to Class" + +dummyP :: Monad m => m (Reft -> b) -> m b +dummyP fm + = fm `ap` return dummyReft + +symsP + = do reserved "\\" + ss <- sepBy symbolP spaces + reserved "->" + return $ (, dummyRSort) <$> ss + <|> return [] + +dummyRSort + = ROth "dummy" + +refasP :: Parser [Refa] +refasP = (try (brackets $ sepBy (RConc <$> predP) semi)) + <|> liftM ((:[]) . RConc) predP + +predicatesP + = try (angles $ sepBy1 predicate1P comma) + <|> return [] + +predicate1P + = try (RProp <$> symsP <*> refP bbaseP) + <|> (RPropP [] . predUReft <$> monoPredicate1P) + <|> (braces $ bRProp <$> symsP' <*> refasP) + where + symsP' = do ss <- symsP + fs <- mapM refreshSym (fst <$> ss) + return $ zip ss fs + refreshSym s = intSymbol s <$> freshIntP + +mmonoPredicateP + = try (angles $ angles monoPredicate1P) + <|> return mempty + +monoPredicateP + = try (angles monoPredicate1P) + <|> return mempty + +monoPredicate1P + = try (reserved "True" >> return mempty) + <|> try (pdVar <$> parens predVarUseP) + <|> (pdVar <$> predVarUseP) + +predVarUseP + = do (p, xs) <- funArgsP + return $ PV p (PVProp dummyTyId) dummySymbol [ (dummyTyId, dummySymbol, x) | x <- xs ] + +funArgsP = try realP <|> empP + where + empP = (,[]) <$> predVarIdP + realP = do EApp lp xs <- funAppP + return (val lp, xs) + + + +------------------------------------------------------------------------ +----------------------- Wrapped Constructors --------------------------- +------------------------------------------------------------------------ + +bRProp [] _ = errorstar "Parse.bRProp empty list" +bRProp syms' expr = RProp ss $ bRVar dummyName mempty mempty r + where + (ss, (v, _)) = (init syms, last syms) + syms = [(y, s) | ((_, s), y) <- syms'] + su = mkSubst [(x, EVar y) | ((x, _), y) <- syms'] + r = su `subst` Reft (v, expr) + +bRVar α s p r = RVar α (U r p s) +bLst (Just t) rs r = RApp (dummyLoc listConName) [t] rs (reftUReft r) +bLst (Nothing) rs r = RApp (dummyLoc listConName) [] rs (reftUReft r) + +bTup [t] _ r | isTauto r = t + | otherwise = t `strengthen` (reftUReft r) +bTup ts rs r = RApp (dummyLoc tupConName) ts rs (reftUReft r) + + +-- Temporarily restore this hack benchmarks/esop2013-submission/Array.hs fails +-- w/o it +-- TODO RApp Int [] [p] true should be syntactically different than RApp Int [] [] p +bCon b s [RPropP _ r1] [] _ r = RApp b [] [] $ r1 `meet` (U r mempty s) +bCon b s rs ts p r = RApp b ts rs $ U r p s + +-- bAppTy v t r = RAppTy (RVar v top) t (reftUReft r) +bAppTy v ts r = (foldl' (\a b -> RAppTy a b mempty) (RVar v mempty) ts) `strengthen` (reftUReft r) + + +reftUReft = \r -> U r mempty mempty +predUReft = \p -> U dummyReft p mempty +dummyReft = mempty +dummyTyId = "" + +------------------------------------------------------------------ +--------------------------- Measures ----------------------------- +------------------------------------------------------------------ + +data Pspec ty ctor + = Meas (Measure ty ctor) + | Assm (LocSymbol, ty) + | Asrt (LocSymbol, ty) + | LAsrt (LocSymbol, ty) + | Asrts ([LocSymbol], (ty, Maybe [Expr])) + | Impt Symbol + | DDecl DataDecl + | Incl FilePath + | Invt (Located ty) + | IAlias (Located ty, Located ty) + | Alias (RTAlias Symbol BareType) + | PAlias (RTAlias Symbol Pred) + | Embed (LocSymbol, FTycon) + | Qualif Qualifier + | Decr (LocSymbol, [Int]) + | LVars LocSymbol + | Lazy LocSymbol + | Pragma (Located String) + | CMeas (Measure ty ()) + | IMeas (Measure ty ctor) + | Class (RClass ty) + +-- | For debugging +instance Show (Pspec a b) where + show (Meas _) = "Meas" + show (Assm _) = "Assm" + show (Asrt _) = "Asrt" + show (LAsrt _) = "LAsrt" + show (Asrts _) = "Asrts" + show (Impt _) = "Impt" + show (DDecl _) = "DDecl" + show (Incl _) = "Incl" + show (Invt _) = "Invt" + show (IAlias _) = "IAlias" + show (Alias _) = "Alias" + show (PAlias _) = "PAlias" + show (Embed _) = "Embed" + show (Qualif _) = "Qualif" + show (Decr _) = "Decr" + show (LVars _) = "LVars" + show (Lazy _) = "Lazy" + show (Pragma _) = "Pragma" + show (CMeas _) = "CMeas" + show (IMeas _) = "IMeas" + show (Class _) = "Class" + + + +-- mkSpec :: String -> [Pspec ty LocSymbol] -> Measure.Spec ty LocSymbol +mkSpec name xs = (name,) + $ Measure.qualifySpec (symbol name) + $ Measure.Spec + { Measure.measures = [m | Meas m <- xs] + , Measure.asmSigs = [a | Assm a <- xs] + , Measure.sigs = [a | Asrt a <- xs] + ++ [(y, t) | Asrts (ys, (t, _)) <- xs, y <- ys] + , Measure.localSigs = [] + , Measure.invariants = [t | Invt t <- xs] + , Measure.ialiases = [t | IAlias t <- xs] + , Measure.imports = [i | Impt i <- xs] + , Measure.dataDecls = [d | DDecl d <- xs] + , Measure.includes = [q | Incl q <- xs] + , Measure.aliases = [a | Alias a <- xs] + , Measure.paliases = [p | PAlias p <- xs] + , Measure.embeds = M.fromList [e | Embed e <- xs] + , Measure.qualifiers = [q | Qualif q <- xs] + , Measure.decr = [d | Decr d <- xs] + , Measure.lvars = [d | LVars d <- xs] + , Measure.lazy = S.fromList [s | Lazy s <- xs] + , Measure.pragmas = [s | Pragma s <- xs] + , Measure.cmeasures = [m | CMeas m <- xs] + , Measure.imeasures = [m | IMeas m <- xs] + , Measure.classes = [c | Class c <- xs] + , Measure.termexprs = [(y, es) | Asrts (ys, (_, Just es)) <- xs, y <- ys] + } + +specP :: Parser (Pspec BareType LocSymbol) +specP + = try (reserved "assume" >> liftM Assm tyBindP ) + <|> (reserved "assert" >> liftM Asrt tyBindP ) + <|> (reserved "Local" >> liftM LAsrt tyBindP ) + <|> (reserved "measure" >> liftM Meas measureP ) + <|> try (reserved "class" >> reserved "measure" >> liftM CMeas cMeasureP) + <|> (reserved "instance" >> reserved "measure" >> liftM IMeas iMeasureP) + <|> (reserved "class" >> liftM Class classP ) + <|> (reserved "import" >> liftM Impt symbolP ) + <|> (reserved "data" >> liftM DDecl dataDeclP ) + <|> (reserved "include" >> liftM Incl filePathP ) + <|> (reserved "invariant" >> liftM Invt invariantP) + <|> (reserved "using" >> liftM IAlias invaliasP ) + <|> (reserved "type" >> liftM Alias aliasP ) + <|> (reserved "predicate" >> liftM PAlias paliasP ) + <|> (reserved "embed" >> liftM Embed embedP ) + <|> (reserved "qualif" >> liftM Qualif qualifierP) + <|> (reserved "Decrease" >> liftM Decr decreaseP ) + <|> (reserved "LAZYVAR" >> liftM LVars lazyVarP ) + <|> (reserved "Strict" >> liftM Lazy lazyVarP ) + <|> (reserved "Lazy" >> liftM Lazy lazyVarP ) + <|> (reserved "LIQUID" >> liftM Pragma pragmaP ) + <|> ({- DEFAULT -} liftM Asrts tyBindsP ) + +pragmaP :: Parser (Located String) +pragmaP = locParserP stringLiteral + +lazyP :: Parser Symbol +lazyP = binderP + +lazyVarP :: Parser LocSymbol +lazyVarP = locParserP binderP + +decreaseP :: Parser (LocSymbol, [Int]) +decreaseP = mapSnd f <$> liftM2 (,) (locParserP binderP) (spaces >> (many integer)) + where f = ((\n -> fromInteger n - 1) <$>) + +filePathP :: Parser FilePath +filePathP = angles $ many1 pathCharP + where + pathCharP = choice $ char <$> pathChars + pathChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['.', '/'] + +tyBindsP :: Parser ([LocSymbol], (BareType, Maybe [Expr])) +tyBindsP = xyP (sepBy (locParserP binderP) comma) dcolon termBareTypeP + +tyBindP :: Parser (LocSymbol, BareType) +tyBindP = xyP (locParserP binderP) dcolon genBareTypeP + +termBareTypeP :: Parser (BareType, Maybe [Expr]) +termBareTypeP + = try termTypeP + <|> (, Nothing) <$> genBareTypeP + +termTypeP + = do t <- genBareTypeP + reserved "/" + es <- brackets $ sepBy exprP comma + return (t, Just es) + +invariantP = locParserP genBareTypeP + +invaliasP + = do t <- locParserP genBareTypeP + reserved "as" + ta <- locParserP genBareTypeP + return (t, ta) + +genBareTypeP + = bareTypeP + +embedP + = xyP locUpperIdP (reserved "as") fTyConP + + +aliasP = rtAliasP id bareTypeP +paliasP = rtAliasP symbol predP + +rtAliasP :: (Symbol -> tv) -> Parser ty -> Parser (RTAlias tv ty) +rtAliasP f bodyP + = do pos <- getPosition + name <- upperIdP + spaces + args <- sepBy aliasIdP spaces + whiteSpace >> reservedOp "=" >> whiteSpace + body <- bodyP + let (tArgs, vArgs) = partition (isLower . headSym) args + return $ RTA name (f <$> tArgs) (f <$> vArgs) body pos + +aliasIdP :: Parser Symbol +aliasIdP = condIdP (['A' .. 'Z'] ++ ['a'..'z'] ++ ['0'..'9']) (isAlpha . head) + +measureP :: Parser (Measure BareType LocSymbol) +measureP + = do (x, ty) <- tyBindP + whiteSpace + eqns <- grabs $ measureDefP $ (rawBodyP <|> tyBodyP ty) + return $ Measure.mkM x ty eqns + +cMeasureP :: Parser (Measure BareType ()) +cMeasureP + = do (x, ty) <- tyBindP + return $ Measure.mkM x ty [] + +iMeasureP :: Parser (Measure BareType LocSymbol) +iMeasureP = measureP + +classP :: Parser (RClass BareType) +classP + = do sups <- superP + c <- locUpperIdP + spaces + tvs <- manyTill tyVarIdP (try $ reserved "where") + ms <- grabs tyBindP + spaces + return $ RClass (fmap symbol c) (mb sups) tvs ms + where + mb Nothing = [] + mb (Just xs) = xs + superP = maybeP (parens ( liftM (toRCls <$>) (bareTypeP `sepBy1` comma)) <* reserved "=>") + toRCls (RApp c ts rs r) = RCls c ts + toRCls t@(RCls _ _) = t + toRCls t = errorstar $ "Parse.toRCls called with" ++ show t + +rawBodyP + = braces $ do + v <- symbolP + reserved "|" + p <- predP <* spaces + return $ R v p + +tyBodyP :: BareType -> Parser Body +tyBodyP ty + = case outTy ty of + Just bt | isPropBareType bt + -> P <$> predP + _ -> E <$> exprP + where outTy (RAllT _ t) = outTy t + outTy (RAllP _ t) = outTy t + outTy (RFun _ _ t _) = Just t + outTy _ = Nothing + +binderP :: Parser Symbol +binderP = try $ symbol <$> idP badc + <|> pwr <$> parens (idP bad) + where + idP p = many1 (satisfy (not . p)) + badc c = (c == ':') || (c == ',') || bad c + bad c = isSpace c || c `elem` "(,)" + pwr s = symbol $ "(" `mappend` s `mappend` ")" + +grabs p = try (liftM2 (:) p (grabs p)) + <|> return [] + +measureDefP :: Parser Body -> Parser (Def LocSymbol) +measureDefP bodyP + = do mname <- locParserP symbolP + (c, xs) <- measurePatP + whiteSpace >> reservedOp "=" >> whiteSpace + body <- bodyP + whiteSpace + let xs' = (symbol . val) <$> xs + return $ Def mname (symbol <$> c) xs' body + +measurePatP :: Parser (LocSymbol, [LocSymbol]) +measurePatP + = try tupPatP + <|> try (parens conPatP) + <|> try (parens consPatP) + <|> (parens nilPatP) + +tupPatP = mkTupPat <$> (parens $ sepBy locLowerIdP comma) +conPatP = (,) <$> locParserP dataConNameP <*> sepBy locLowerIdP whiteSpace +consPatP = mkConsPat <$> locLowerIdP <*> colon <*> locLowerIdP +nilPatP = mkNilPat <$> brackets whiteSpace + +mkTupPat zs = (tupDataCon (length zs), zs) +mkNilPat _ = (dummyLoc "[]", [] ) +mkConsPat x c y = (dummyLoc ":" , [x, y]) +tupDataCon n = dummyLoc $ symbol $ "(" <> replicate (n - 1) ',' <> ")" + + +------------------------------------------------------------------------------- +--------------------------------- Predicates ---------------------------------- +------------------------------------------------------------------------------- + +dataConFieldsP + = (braces $ sepBy predTypeDDP comma) + <|> (sepBy (parens predTypeDDP) spaces) + +predTypeDDP + = liftM2 (,) bbindP bareTypeP + +dataConP + = do x <- locParserP dataConNameP + spaces + xts <- dataConFieldsP + return (x, xts) + +dataConNameP + = try upperIdP + <|> pwr <$> parens (idP bad) + where + idP p = symbol <$> many1 (satisfy (not . p)) + bad c = isSpace c || c `elem` "(,)" + pwr s = "(" <> s <> ")" + +dataSizeP + = (brackets $ (Just . mkFun) <$> locLowerIdP) + <|> return Nothing + where mkFun s = \x -> EApp (symbol <$> s) [EVar x] + +dataDeclP :: Parser DataDecl +dataDeclP = try dataDeclFullP <|> dataDeclSizeP + + +dataDeclSizeP + = do pos <- getPosition + x <- locUpperIdP + spaces + fsize <- dataSizeP + return $ D x [] [] [] [] pos fsize + +dataDeclFullP + = do pos <- getPosition + x <- locUpperIdP + spaces + fsize <- dataSizeP + spaces + ts <- sepBy tyVarIdP spaces + ps <- predVarDefsP + whiteSpace >> reservedOp "=" >> whiteSpace + dcs <- sepBy dataConP (reserved "|") + whiteSpace + return $ D x ts ps [] dcs pos fsize + + +--------------------------------------------------------------------- +------------ Interacting with Fixpoint ------------------------------ +--------------------------------------------------------------------- + +grabUpto p + = try (lookAhead p >>= return . Just) + <|> try (eof >> return Nothing) + <|> (anyChar >> grabUpto p) + +betweenMany leftP rightP p + = do z <- grabUpto leftP + case z of + Just _ -> liftM2 (:) (between leftP rightP p) (betweenMany leftP rightP p) + Nothing -> return [] + +-- specWrap = between (string "{-@" >> spaces) (spaces >> string "@-}") +specWraps = betweenMany (string "{-@" >> spaces) (spaces >> string "@-}") + +--------------------------------------------------------------- +-- | Bundling Parsers into a Typeclass ------------------------ +--------------------------------------------------------------- + +instance Inputable BareType where + rr' = doParse' bareTypeP + +instance Inputable (Measure BareType LocSymbol) where + rr' = doParse' measureP + +{- +--------------------------------------------------------------- +--------------------------- Testing --------------------------- +--------------------------------------------------------------- + +sa = "0" +sb = "x" +sc = "(x0 + y0 + z0) " +sd = "(x+ y * 1)" +se = "_|_ " +sf = "(1 + x + _|_)" +sg = "f(x,y,z)" +sh = "(f((x+1), (y * a * b - 1), _|_))" +si = "(2 + f((x+1), (y * a * b - 1), _|_))" + +s0 = "true" +s1 = "false" +s2 = "v > 0" +s3 = "(0 < v && v < 100)" +s4 = "(x < v && v < y+10 && v < z)" +s6 = "[(v > 0)]" +s6' = "x" +s7' = "(x <=> y)" +s8' = "(x <=> a = b)" +s9' = "(x <=> (a <= b && b < c))" + +s7 = "{ v: Int | [(v > 0)] }" +s8 = "x:{ v: Int | v > 0 } -> {v : Int | v >= x}" +s9 = "v = x+y" +s10 = "{v: Int | v = x + y}" + +s11 = "x:{v:Int | true } -> {v:Int | true }" +s12 = "y : {v:Int | true } -> {v:Int | v = x }" +s13 = "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" +s14 = "x:{v:a | true} -> y:{v:b | true } -> {v:a | (x < v && v < y) }" +s15 = "x:Int -> Bool" +s16 = "x:Int -> y:Int -> {v:Int | v = x + y}" +s17 = "a" +s18 = "x:a -> Bool" +s20 = "forall a . x:Int -> Bool" + +s21 = "x:{v : GHC.Prim.Int# | true } -> {v : Int | true }" + +r0 = (rr s0) :: Pred +r0' = (rr s0) :: [Refa] +r1 = (rr s1) :: [Refa] + + +e1, e2 :: Expr +e1 = rr "(k_1 + k_2)" +e2 = rr "k_1" + +o1, o2, o3 :: FixResult Integer +o1 = rr "SAT " +o2 = rr "UNSAT [1, 2, 9,10]" +o3 = rr "UNSAT []" + +-- sol1 = doParse solution1P "solution: k_5 := [0 <= VV_int]" +-- sol2 = doParse solution1P "solution: k_4 := [(0 <= VV_int)]" + +b0, b1, b2, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13 :: BareType +b0 = rr "Int" +b1 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}" +b2 = rr "x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y}" +b4 = rr "forall a . x : a -> Bool" +b5 = rr "Int -> Int -> Int" +b6 = rr "(Int -> Int) -> Int" +b7 = rr "({v: Int | v > 10} -> Int) -> Int" +b8 = rr "(x:Int -> {v: Int | v > x}) -> {v: Int | v > 10}" +b9 = rr "x:Int -> {v: Int | v > x} -> {v: Int | v > 10}" +b10 = rr "[Int]" +b11 = rr "x:[Int] -> {v: Int | v > 10}" +b12 = rr "[Int] -> String" +b13 = rr "x:(Int, [Bool]) -> [(String, String)]" + +-- b3 :: BareType +-- b3 = rr "x:Int -> y:Int -> {v:Bool | ((v is True) <=> x = y)}" + +m1 = ["len :: [a] -> Int", "len (Nil) = 0", "len (Cons x xs) = 1 + len(xs)"] +m2 = ["tog :: LL a -> Int", "tog (Nil) = 100", "tog (Cons y ys) = 200"] + +me1, me2 :: Measure BareType Symbol +me1 = (rr $ intercalate "\n" m1) +me2 = (rr $ intercalate "\n" m2) +-} diff --git a/src/Language/Haskell/Liquid/PredType.hs b/src/Language/Haskell/Liquid/PredType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/PredType.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, UndecidableInstances, TupleSections, OverloadedStrings #-} +module Language.Haskell.Liquid.PredType ( + PrType + , TyConP (..), DataConP (..) + , dataConTy + , dataConPSpecType + , makeTyConInfo + , unify + , replacePreds + + , replacePredsWithRefs + , pVartoRConc + + -- * Compute `Type` of GHC `CoreExpr` + , exprType + + -- * Dummy `Type` that represents _all_ abstract-predicates + , predType + + -- * Compute @RType@ of a given @PVar@ + , pvarRType + + , substParg + , pApp + , wiredSortedSyms + ) where + +-- import PprCore (pprCoreExpr) +import Id (idType) +import CoreSyn hiding (collectArgs) +import Type +import TypeRep +import qualified TyCon as TC +import Literal +import Coercion (coercionType, coercionKind) +import Pair (pSnd) +import FastString (sLit) +import qualified Outputable as O +import Text.PrettyPrint.HughesPJ +import DataCon + +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.List (partition, foldl') +import Data.Monoid (mempty, mappend) +import qualified Data.Text as T + +import Language.Fixpoint.Misc +import Language.Fixpoint.Types hiding (Predicate, Expr) +import qualified Language.Fixpoint.Types as F +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.RefType hiding (generalize) +import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.Misc + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad.State +import Data.List (nub) + +import Data.Default + +import Debug.Trace (trace) + +makeTyConInfo = hashMapMapWithKey mkRTyCon . M.fromList + +mkRTyCon :: TC.TyCon -> TyConP -> RTyCon +mkRTyCon tc (TyConP αs' ps ls cv conv size) = RTyCon tc pvs' (mkTyConInfo tc cv conv size) + where τs = [rVar α :: RSort | α <- TC.tyConTyVars tc] + pvs' = subts (zip αs' τs) <$> ps + +dataConPSpecType :: DataCon -> DataConP -> SpecType +dataConPSpecType dc (DataConP _ vs ps ls cs yts rt) = mkArrow vs ps ls ts' rt' + where + (xs, ts) = unzip $ reverse yts + mkDSym = (`mappend` symbol dc) . (`mappend` "_") . symbol + ys = mkDSym <$> xs + tx _ [] [] [] = [] + tx su (x:xs) (y:ys) (t:ts) = (y, subst (F.mkSubst su) t) + : tx ((x, F.EVar y):su) xs ys ts + yts' = tx [] xs ys ts + ts' = map ("" ,) cs ++ yts' + su = F.mkSubst [(x, F.EVar y) | (x, y) <- zip xs ys] + rt' = subst su rt + +instance PPrint TyConP where + pprint (TyConP vs ps ls _ _ _) + = (parens $ hsep (punctuate comma (map pprint vs))) <+> + (parens $ hsep (punctuate comma (map pprint ps))) <+> + (parens $ hsep (punctuate comma (map pprint ls))) + +instance Show TyConP where + show = showpp -- showSDoc . ppr + +instance PPrint DataConP where + pprint (DataConP _ vs ps ls cs yts t) + = (parens $ hsep (punctuate comma (map pprint vs))) <+> + (parens $ hsep (punctuate comma (map pprint ps))) <+> + (parens $ hsep (punctuate comma (map pprint ls))) <+> + (parens $ hsep (punctuate comma (map pprint cs))) <+> + (parens $ hsep (punctuate comma (map pprint yts))) <+> + pprint t + +instance Show DataConP where + show = showpp + +dataConTy m (TyVarTy v) + = M.lookupDefault (rVar v) (RTV v) m +dataConTy m (FunTy t1 t2) + = rFun dummySymbol (dataConTy m t1) (dataConTy m t2) +dataConTy m (ForAllTy α t) + = RAllT (rTyVar α) (dataConTy m t) +dataConTy _ t + | Just t' <- ofPredTree (classifyPredType t) + = t' +dataConTy m (TyConApp c ts) + = rApp c (dataConTy m <$> ts) [] mempty +dataConTy _ _ + = error "ofTypePAppTy" + +--------------------------------------------------------------------------- +-- | Unify PrType with SpecType ------------------------------------------- +--------------------------------------------------------------------------- +unify :: Maybe PrType -> SpecType -> SpecType +--------------------------------------------------------------------------- +unify (Just pt) rt = evalState (unifyS rt pt) S.empty +unify _ t = t + +--------------------------------------------------------------------------- +unifyS :: SpecType -> PrType -> State (S.HashSet UsedPVar) SpecType +--------------------------------------------------------------------------- + +unifyS (RAllS s t) pt + = do t' <- unifyS t pt + return $ RAllS s t' + +unifyS t (RAllS s pt) + = do t' <- unifyS t pt + return $ RAllS s t' + +unifyS (RAllP p t) pt + = do t' <- unifyS t pt + s <- get + put $ S.delete (uPVar p) s + if (uPVar p `S.member` s) then return $ RAllP p t' else return t' + +unifyS t (RAllP p pt) + = do t' <- unifyS t pt + s <- get + put $ S.delete (uPVar p) s + if (uPVar p `S.member` s) then return $ RAllP p t' else return t' + +unifyS (RAllT (v@(RTV α)) t) (RAllT v' pt) + = do t' <- unifyS t $ subsTyVar_meet (v', (rVar α) :: RSort, RVar v mempty) pt + return $ RAllT v t' + +unifyS (RFun x rt1 rt2 _) (RFun x' pt1 pt2 _) + = do t1' <- unifyS rt1 pt1 + t2' <- unifyS rt2 $ substParg (x', EVar x) pt2 + return $ rFun x t1' t2' + +unifyS (RAppTy rt1 rt2 r) (RAppTy pt1 pt2 p) + = do t1' <- unifyS rt1 pt1 + t2' <- unifyS rt2 pt2 + return $ RAppTy t1' t2' (bUnify r p) + +unifyS t@(RCls _ _) (RCls _ _) + = return t + +unifyS (RVar v a) (RVar _ p) + = do modify $ \s -> s `S.union` (S.fromList $ pvars p) + return $ RVar v $ bUnify a p + +unifyS (RApp c ts rs r) (RApp _ pts ps p) + = do modify $ \s -> s `S.union` fm + ts' <- zipWithM unifyS ts pts + return $ RApp c ts' rs (bUnify r p) + where + fm = S.fromList $ concatMap pvars (p:fps) + fps = getR <$> ps + getR (RPropP _ r) = r + getR (RProp _ _ ) = mempty + +unifyS (RAllE x tx t) (RAllE x' tx' t') | x == x' + = RAllE x <$> unifyS tx tx' <*> unifyS t t' + +unifyS (REx x tx t) (REx x' tx' t') | x == x' + = REx x <$> unifyS tx tx' <*> unifyS t t' + +unifyS t (REx x' tx' t') + = REx x' ((\p -> U mempty p mempty) <$> tx') <$> unifyS t t' + +unifyS t@(RVar v a) (RAllE x' tx' t') + = RAllE x' ((\p -> U mempty p mempty)<$> tx') <$> (unifyS t t') + +unifyS t1 t2 + = error ("unifyS" ++ show t1 ++ " with " ++ show t2) + +-- pToReft p = Reft (vv, [RPvar p]) +pToReft = (\p -> U mempty p mempty) . pdVar + +bUnify r (Pr pvs) = foldl' meet r $ pToReft <$> pvs + +-- ORIG unifyRef (RPropP s r) p = RPropP s $ bUnify r p -- (foldl' meet r $ pToReft <$> pvs) +-- ORIG unifyRef (RProp s t) (Pr pvs) = RProp s $ foldl' strengthen t $ pToReft <$> pvs + +-- ORIG zipWithZero f xz yz = go +-- ORIG where +-- ORIG go [] ys = (xz `f`) <$> ys +-- ORIG go xs [] = (`f` yz) <$> xs +-- ORIG go (x:xs) (y:ys) = f x y : go xs ys + +-- ORIG zipWithZero _ _ _ [] [] = [] +-- ORIG zipWithZero f xz yz [] (y:ys) = f xz y : zipWithZero f xz yz [] ys +-- ORIG zipWithZero f xz yz (x:xs) [] = f x yz : zipWithZero f xz yz xs [] +-- ORIG zipWithZero f xz yz (x:xs) (y:ys) = f x y : zipWithZero f xz yz xs ys + +---------------------------------------------------------------------------- +----- Interface: Replace Predicate With Uninterprented Function Symbol ----- +---------------------------------------------------------------------------- + +replacePredsWithRefs (p, r) (U (Reft(v, rs)) (Pr ps) s) + = U (Reft (v, rs ++ rs')) (Pr ps2) s + where rs' = r . (v,) . pargs <$> ps1 + (ps1, ps2) = partition (==p) ps + freeSymbols = snd3 <$> filter (\(_, x, y) -> EVar x == y) pargs1 + pargs1 = concatMap pargs ps1 + +pVartoRConc p (v, args) | length args == length (pargs p) + = RConc $ pApp (pname p) $ EVar v:(thd3 <$> args) + +pVartoRConc p (v, args) + = RConc $ pApp (pname p) $ EVar v : args' + where args' = (thd3 <$> args) ++ (drop (length args) (thd3 <$> pargs p)) + +----------------------------------------------------------------------- +-- | @pvarRType π@ returns a trivial @RType@ corresponding to the +-- function signature for a @PVar@ @π@. For example, if +-- @π :: T1 -> T2 -> T3 -> Prop@ +-- then @pvarRType π@ returns an @RType@ with an @RTycon@ called +-- @predRTyCon@ `RApp predRTyCon [T1, T2, T3]` +----------------------------------------------------------------------- +pvarRType :: (PPrint r, Reftable r) => PVar RSort -> RRType r +----------------------------------------------------------------------- +pvarRType (PV _ k {- (PVProp τ) -} _ args) = rpredType k (fst3 <$> args) -- (ty:tys) + -- where + -- ty = uRTypeGen τ + -- tys = uRTypeGen . fst3 <$> args + + +-- rpredType :: (PPrint r, Reftable r) => PVKind (RRType r) -> [RRType r] -> RRType r +rpredType (PVProp t) ts = RApp predRTyCon (uRTypeGen <$> t : ts) [] mempty +rpredType PVHProp ts = RApp wpredRTyCon (uRTypeGen <$> ts) [] mempty + +predRTyCon :: RTyCon +predRTyCon = symbolRTyCon predName + +wpredRTyCon :: RTyCon +wpredRTyCon = symbolRTyCon wpredName + +symbolRTyCon :: Symbol -> RTyCon +symbolRTyCon n = RTyCon (stringTyCon 'x' 42 $ symbolString n) [] def + +------------------------------------------------------------------------------------- +-- | Instantiate `PVar` with `RTProp` ----------------------------------------------- +------------------------------------------------------------------------------------- +-- | @replacePreds@ is the main function used to substitute an (abstract) +-- predicate with a concrete Ref, that is either an `RProp` or `RHProp` +-- type. The substitution is invoked to obtain the `SpecType` resulting +-- at /predicate application/ sites in 'Language.Haskell.Liquid.Constraint'. +-- The range of the `PVar` substitutions are /fresh/ or /true/ `RefType`. +-- That is, there are no further _quantified_ `PVar` in the target. +------------------------------------------------------------------------------------- +replacePreds :: String -> SpecType -> [(RPVar, SpecProp)] -> SpecType +------------------------------------------------------------------------------------- +replacePreds msg = foldl' go + where + go z (π, t@(RProp _ _)) = substPred msg (π, t) z + go _ (_, RPropP _ _) = error "replacePreds on RPropP" + go _ (_, RHProp _ _) = errorstar "TODO:EFFECTS:replacePreds" + +-- TODO: replace `replacePreds` with +-- instance SubsTy RPVar (Ref RReft SpecType) SpecType where +-- subt (pv, r) t = replacePreds "replacePred" t (pv, r) + +-- replacePreds :: String -> SpecType -> [(RPVar, Ref Reft RefType)] -> SpecType +-- replacePreds msg = foldl' go +-- where go z (π, RProp t) = substPred msg (π, t) z +-- go z (π, RPropP r) = replacePVarReft (π, r) <$> z + +------------------------------------------------------------------------------- +substPred :: String -> (RPVar, SpecProp) -> SpecType -> SpecType +------------------------------------------------------------------------------- + +substPred _ (π, RProp ss (RVar a1 r1)) t@(RVar a2 r2) + | isPredInReft && a1 == a2 = RVar a1 $ meetListWithPSubs πs ss r1 r2' + | isPredInReft = errorstar ("substPred RVar Var Mismatch" ++ show (a1, a2)) + | otherwise = t + where + (r2', πs) = splitRPvar π r2 + isPredInReft = not $ null πs + +substPred msg su@(π, _ ) (RApp c ts rs r) + | null πs = t' + | otherwise = substRCon msg su t' πs r2' + where + t' = RApp c (substPred msg su <$> ts) (substPredP msg su <$> rs) r + (r2', πs) = splitRPvar π r + +substPred msg (p, tp) (RAllP (q@(PV _ _ _ _)) t) + | p /= q = RAllP q $ substPred msg (p, tp) t + | otherwise = RAllP q t + +substPred msg su (RAllT a t) = RAllT a (substPred msg su t) + +substPred msg su@(π,_ ) (RFun x t t' r) + | null πs = RFun x (substPred msg su t) (substPred msg su t') r + | otherwise = {-meetListWithPSubs πs πt -}(RFun x t t' r') + where (r', πs) = splitRPvar π r + +substPred msg su (RRTy e r o t) = RRTy (mapSnd (substPred msg su) <$> e) r o (substPred msg su t) +substPred msg su (RCls c ts) = RCls c (substPred msg su <$> ts) +substPred msg su (RAllE x t t') = RAllE x (substPred msg su t) (substPred msg su t') +substPred msg su (REx x t t') = REx x (substPred msg su t) (substPred msg su t') +substPred _ _ t = t + +-- | Requires: @not $ null πs@ +-- substRCon :: String -> (RPVar, SpecType) -> SpecType -> SpecType + +substRCon msg (_, RProp ss (RApp c1 ts1 rs1 r1)) (RApp c2 ts2 rs2 _) πs r2' + | rtc_tc c1 == rtc_tc c2 = RApp c1 ts rs $ meetListWithPSubs πs ss r1 r2' + where + ts = safeZipWith (msg ++ ": substRCon") strSub ts1 ts2 + rs = safeZipWith (msg ++ ": substRCon2") strSubR rs1' rs2' + -- TODO: REMOVE `pad` just use rs2 ? + (rs1', rs2') = pad "substRCon" top rs1 rs2 + strSub r1 r2 = meetListWithPSubs πs ss r1 r2 + strSubR r1 r2 = meetListWithPSubsRef πs ss r1 r2 + + + +substRCon msg su t _ _ = errorstar $ msg ++ " substRCon " ++ showpp (su, t) + +substPredP msg su@(p, RProp ss tt) (RProp s t) + = RProp ss' $ substPred (msg ++ ": substPredP") su t + where + ss' = drop n ss ++ s + n = length ss - length (freeArgsPs p t) + +substPredP _ _ (RHProp _ _) + = errorstar "TODO:EFFECTS:substPredP" + +substPredP _ _ (RPropP _ _) + = error $ "RPropP found in substPredP" + + + + +splitRPvar pv (U x (Pr pvs) s) = (U x (Pr pvs') s, epvs) + where + (epvs, pvs') = partition (uPVar pv ==) pvs + + +isPredInType p (RVar _ r) + = isPredInURef p r +isPredInType p (RFun _ t1 t2 r) + = isPredInURef p r || isPredInType p t1 || isPredInType p t2 +isPredInType p (RAllT _ t) + = isPredInType p t +isPredInType p (RAllP p' t) + = not (p == p') && isPredInType p t +isPredInType p (RApp _ ts _ r) + = isPredInURef p r || any (isPredInType p) ts +isPredInType p (RCls _ ts) + = any (isPredInType p) ts +isPredInType p (RAllE _ t1 t2) + = isPredInType p t1 || isPredInType p t2 +isPredInType p (RAppTy t1 t2 r) + = isPredInURef p r || isPredInType p t1 || isPredInType p t2 +isPredInType _ (RExprArg _) + = False +isPredInType _ (ROth _) + = False + +isPredInURef p (U _ (Pr ps) _) = any (uPVar p ==) ps + +freeArgsPs p (RVar _ r) + = freeArgsPsRef p r +freeArgsPs p (RFun _ t1 t2 r) + = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 +freeArgsPs p (RAllT _ t) + = freeArgsPs p t +freeArgsPs p (RAllP p' t) + | p == p' = [] + | otherwise = freeArgsPs p t +freeArgsPs p (RApp _ ts _ r) + = nub $ freeArgsPsRef p r ++ concatMap (freeArgsPs p) ts +freeArgsPs p (RCls _ ts) + = nub $ concatMap (freeArgsPs p) ts +freeArgsPs p (RAllE _ t1 t2) + = nub $ freeArgsPs p t1 ++ freeArgsPs p t2 +freeArgsPs p (RAppTy t1 t2 r) + = nub $ freeArgsPsRef p r ++ freeArgsPs p t1 ++ freeArgsPs p t2 +freeArgsPs _ (RExprArg _) + = [] +freeArgsPs _ (ROth _) + = [] + +freeArgsPsRef p (U _ (Pr ps) _) = [x | (_, x, w) <- (concatMap pargs ps'), (EVar x) == w] + where + ps' = f <$> filter (uPVar p ==) ps + f q = q {pargs = pargs q ++ drop (length (pargs q)) (pargs $ uPVar p)} + +meetListWithPSubs πs ss r1 r2 = foldl' (meetListWithPSub ss r1) r2 πs +meetListWithPSubsRef πs ss r1 r2 = foldl' ((meetListWithPSubRef ss) r1) r2 πs + +meetListWithPSub :: (Reftable r, PPrint t) => [(Symbol, RSort)]-> r -> r -> PVar t -> r +meetListWithPSub ss r1 r2 π + | all (\(_, x, EVar y) -> x == y) (pargs π) + = r2 `meet` r1 + | all (\(_, x, EVar y) -> x /= y) (pargs π) + = r2 `meet` (subst su r1) + | otherwise + = errorstar $ "PredType.meetListWithPSub partial application to " ++ showpp π + where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)] + +meetListWithPSubRef ss (RProp s1 r1) (RProp s2 r2) π + | all (\(_, x, EVar y) -> x == y) (pargs π) + = RProp s1 $ r2 `meet` r1 + | all (\(_, x, EVar y) -> x /= y) (pargs π) + = RProp s2 $ r2 `meet` (subst su r1) + | otherwise + = errorstar $ "PredType.meetListWithPSubRef partial application to " ++ showpp π + where su = mkSubst [(x, y) | (x, (_, _, y)) <- zip (fst <$> ss) (pargs π)] + + +---------------------------------------------------------------------------- +-- | Interface: Modified CoreSyn.exprType due to predApp ------------------- +---------------------------------------------------------------------------- +predType :: Type +predType = symbolType predName + +wpredName, predName :: Symbol +predName = "Pred" +wpredName = "WPred" + +symbolType = TyVarTy . symbolTyVar + +---------------------------------------------------------------------------- +exprType :: CoreExpr -> Type +---------------------------------------------------------------------------- +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let _ body) = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkPiType binder (exprType expr) +exprType (App e1 (Var v)) + | isPredType v = exprType e1 +exprType e@(App _ _) + | (f, es) <- collectArgs e = applyTypeToArgs e (exprType f) es +exprType _ = error "PredType : exprType" + +-- | @collectArgs@ takes a nested application expression and returns +-- the the function being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr = go expr [] + where + go (App f (Var v)) as + | isPredType v = go f as + go (App f a) as = go f (a:as) + go e as = (e, as) + +isPredType v = eqType (idType v) predType + +-- | A more efficient version of 'applyTypeToArg' when we have several arguments. +-- The first argument is just for debugging, and gives some context +-- RJ: This function is UGLY. Two nested levels of where is a BAD idea. +-- Please fix. + +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type + +applyTypeToArgs _ op_ty [] = op_ty + +applyTypeToArgs e op_ty (Type ty : args) + = -- Accumulate type arguments so we can instantiate all at once + go [ty] args + where + go rev_tys (Type ty : args) = go (ty:rev_tys) args + go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args + where + op_ty' = applyTysD msg op_ty (reverse rev_tys) + msg = O.text ("MYapplyTypeToArgs: " ++ panic_msg e op_ty) + + +applyTypeToArgs e op_ty (_ : args) + = case (splitFunTy_maybe op_ty) of + Just (_, res_ty) -> applyTypeToArgs e res_ty args + Nothing -> errorstar $ "MYapplyTypeToArgs" ++ panic_msg e op_ty + +panic_msg :: CoreExpr -> Type -> String +panic_msg e op_ty = showPpr e ++ " :: " ++ showPpr op_ty + +substParg :: Functor f => (Symbol, F.Expr) -> f Predicate -> f Predicate +substParg (x, y) = fmap fp + where + fxy s = if (s == EVar x) then y else s + fp = subvPredicate (\pv -> pv { pargs = mapThd3 fxy <$> pargs pv }) + +------------------------------------------------------------------------------- +----------------------------- Predicate Application -------------------------- +------------------------------------------------------------------------------- + +pappArity = 7 + +-- pappSym n = S $ "papp" ++ show n + +pappSort n = FFunc (2 * n) $ [ptycon] ++ args ++ [bSort] + 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]] + +predFTyCon = symbolFTycon $ dummyLoc predName + +-- pApp :: Symbol -> [F.Expr] -> Pred +-- pApp p es= PBexp $ EApp (dummyLoc $ pappSym $ length es) (EVar p:es) + diff --git a/src/Language/Haskell/Liquid/PrettyPrint.hs b/src/Language/Haskell/Liquid/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/PrettyPrint.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Module with all the printing and serialization routines + +module Language.Haskell.Liquid.PrettyPrint ( + + -- * Tidy level + Tidy (..) + + -- * Printing RType + , rtypeDoc + , ppr_rtype + + -- * Printing an Orderable List + , pprManyOrdered + + -- * Printing a List with many large items + , pprintLongList + , ppSpine + ) where + +import Type (tidyType) +import ErrUtils (ErrMsg) +import HscTypes (SourceError) +import SrcLoc -- (RealSrcSpan, SrcSpan (..)) +import GHC (Name, Class) +import VarEnv (emptyTidyEnv) +import Language.Haskell.Liquid.Misc +import Language.Haskell.Liquid.GhcMisc +import Text.PrettyPrint.HughesPJ +import Language.Fixpoint.Types hiding (Predicate) +import Language.Fixpoint.Misc +import Language.Haskell.Liquid.Types hiding (sort) +import Language.Fixpoint.Names (dropModuleNames, propConName, hpropConName) +import TypeRep hiding (maybeParen, pprArrowChain) +import Text.Parsec.Pos (SourcePos, newPos, sourceName, sourceLine, sourceColumn) +import Text.Parsec.Error (ParseError) +import Var (Var) +import Control.Applicative ((<*>), (<$>)) +import Data.Maybe (fromMaybe) +import Data.List (sort, sortBy) +import Data.Function (on) +import Data.Monoid (mempty) +import Data.Aeson +import qualified Data.Text as T +import Data.Interned +import qualified Data.HashMap.Strict as M + + +instance PPrint SrcSpan where + pprint = pprDoc + +instance PPrint Doc where + pprint x = x + +instance PPrint ErrMsg where + pprint = text . show + +instance PPrint SourceError where + pprint = text . show + +-- instance PPrint ParseError where +-- pprint = text . show + +instance PPrint LParseError where + pprint (LPE _ msgs) = text "Parse Error: " <> vcat (map pprint msgs) + +instance PPrint Var where + pprint = pprDoc + +instance PPrint Name where + pprint = pprDoc + +instance PPrint Type where + pprint = pprDoc . tidyType emptyTidyEnv + +instance PPrint Class where + pprint = pprDoc + +instance Show Predicate where + show = showpp + + +-- | Printing an Ordered List + +--------------------------------------------------------------- +pprManyOrdered :: (PPrint a, Ord a) => Tidy -> String -> [a] -> [Doc] +--------------------------------------------------------------- +pprManyOrdered k msg = map ((text msg <+>) . pprintTidy k) . sort + + +--------------------------------------------------------------- +-- | Pretty Printing RefType ---------------------------------- +--------------------------------------------------------------- + +-- Should just make this a @Pretty@ instance but its too damn tedious +-- to figure out all the constraints. + +rtypeDoc k = ppr_rtype (ppE k) TopPrec + where + ppE Lossy = ppEnvShort ppEnv + ppE Full = ppEnv + +ppr_rtype bb p t@(RAllT _ _) + = ppr_forall bb p t +ppr_rtype bb p t@(RAllP _ _) + = ppr_forall bb p t +ppr_rtype bb p t@(RAllS _ _) + = ppr_forall bb p t +ppr_rtype _ _ (RVar a r) + = ppTy r $ pprint a +ppr_rtype bb p (RFun x t t' _) + = pprArrowChain p $ ppr_dbind bb FunPrec x t : ppr_fun_tail bb t' +ppr_rtype bb p (RApp c [t] rs r) + | isList c + = ppTy r $ brackets (ppr_rtype bb p t) <> ppReftPs bb rs +ppr_rtype bb p (RApp c ts rs r) + | isTuple c + = ppTy r $ parens (intersperse comma (ppr_rtype bb p <$> ts)) <> ppReftPs bb rs + + +ppr_rtype bb p (RApp c ts rs r) + | isEmpty rsDoc && isEmpty tsDoc + = ppTy r $ ppT c + | otherwise + = ppTy r $ parens $ ppT c <+> rsDoc <+> tsDoc + where + rsDoc = ppReftPs bb rs + tsDoc = hsep (ppr_rtype bb p <$> ts) + ppT | ppShort bb = text . symbolString . dropModuleNames . symbol . render . ppTycon + | otherwise = ppTycon + + +ppr_rtype bb p (RCls c ts) + = ppr_cls bb p c ts +ppr_rtype bb p t@(REx _ _ _) + = ppExists bb p t +ppr_rtype bb p t@(RAllE _ _ _) + = ppAllExpr bb p t +ppr_rtype _ _ (RExprArg e) + = braces $ pprint e +ppr_rtype bb p (RAppTy t t' r) + = ppTy r $ ppr_rtype bb p t <+> ppr_rtype bb p t' +ppr_rtype _ _ (ROth s) + = text $ "???-" ++ symbolString s +ppr_rtype bb p (RRTy e r o t) + = sep [ppp (pprint o <+> ppe <+> pprint r), ppr_rtype bb p t] + where ppe = (hsep $ punctuate comma (pprint <$> e)) <+> colon <> colon + ppp = \doc -> text "<<" <+> doc <+> text ">>" +ppr_rtype _ _ (RHole r) + = ppTy r $ text "_" + +ppSpine (RAllT _ t) = text "RAllT" <+> parens (ppSpine t) +ppSpine (RAllP _ t) = text "RAllP" <+> parens (ppSpine t) +ppSpine (RAllE _ _ t) = text "RAllE" <+> parens (ppSpine t) +ppSpine (REx _ _ t) = text "REx" <+> parens (ppSpine t) +ppSpine (RFun _ i o _) = ppSpine i <+> text "->" <+> ppSpine o +ppSpine (RAppTy t t' _) = text "RAppTy" <+> parens (ppSpine t) <+> parens (ppSpine t') +ppSpine (RHole r) = text "RHole" +ppSpine (RCls c ts) = text "RCls" <+> parens (ppCls c ts) +ppSpine (RApp c ts rs _) = text "RApp" <+> parens (pprint c) +ppSpine (RVar v _) = text "RVar" +ppSpine (RExprArg _) = text "RExprArg" +ppSpine (ROth s) = text "ROth" <+> text (symbolString s) +ppSpine (RRTy _ _ _ _) = text "RRTy" + +-- | From GHC: TypeRep +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain :: Prec -> [Doc] -> Doc +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] + +-- | From GHC: TypeRep +maybeParen :: Prec -> Prec -> Doc -> Doc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + + +-- ppExists :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc +ppExists bb p t + = text "exists" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' + where (zs, t') = split [] t + split zs (REx x t t') = split ((x,t):zs) t' + split zs t = (reverse zs, t) + +-- ppAllExpr :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc +ppAllExpr bb p t + = text "forall" <+> brackets (intersperse comma [ppr_dbind bb TopPrec x t | (x, t) <- zs]) <> dot <> ppr_rtype bb p t' + where (zs, t') = split [] t + split zs (RAllE x t t') = split ((x,t):zs) t' + split zs t = (reverse zs, t) + +ppReftPs bb rs + | all isTauto rs = empty + | not (ppPs ppEnv) = empty + | otherwise = angleBrackets $ hsep $ punctuate comma $ pprint <$> rs + +-- ppr_dbind :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> Symbol -> RType p c tv r -> Doc +ppr_dbind bb p x t + | isNonSymbol x || (x == dummySymbol) + = ppr_rtype bb p t + | otherwise + = pprint x <> colon <> ppr_rtype bb p t + +-- ppr_fun_tail :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> RType p c tv r -> [Doc] +ppr_fun_tail bb (RFun b t t' _) + = (ppr_dbind bb FunPrec b t) : (ppr_fun_tail bb t') +ppr_fun_tail bb t + = [ppr_rtype bb TopPrec t] + +-- ppr_forall :: (RefTypable p c tv (), RefTypable p c tv r) => Bool -> Prec -> RType p c tv r -> Doc +ppr_forall bb p t + = maybeParen p FunPrec $ sep [ ppr_foralls (ppPs bb) (ty_vars trep) (ty_preds trep) (ty_labels trep) , ppr_clss cls, ppr_rtype bb TopPrec t' ] + where + trep = toRTypeRep t + (cls, t') = bkClass $ fromRTypeRep $ trep {ty_vars = [], ty_preds = [], ty_labels = []} + + ppr_foralls False _ _ _= empty + ppr_foralls _ [] [] [] = empty + ppr_foralls True αs πs ss = text "forall" <+> dαs αs <+> dπs (ppPs bb) πs <+> dss (ppSs bb) ss <> dot + ppr_clss [] = empty + ppr_clss cs = (parens $ hsep $ punctuate comma (uncurry (ppr_cls bb p) <$> cs)) <+> text "=>" + + dαs αs = sep $ pprint <$> αs + + dπs _ [] = empty + dπs False _ = empty + dπs True πs = angleBrackets $ intersperse comma $ ppr_pvar_def pprint <$> πs + dss _ [] = empty + dss _ ss = angleBrackets $ intersperse comma $ pprint <$> ss + + +ppr_cls bb p c ts + = pp c <+> hsep (map (ppr_rtype bb p) ts) + where + pp | ppShort bb = text . symbolString . dropModuleNames . symbol . render . pprint + | otherwise = pprint + + +ppr_pvar_def pprv (PV s t _ xts) + = pprint s <+> dcolon <+> intersperse arrow dargs <+> ppr_pvar_kind pprv t + + where + dargs = [pprv t | (t,_,_) <- xts] + +ppr_pvar_kind pprv (PVProp t) = pprv t <+> arrow <+> ppr_name propConName +ppr_pvar_kind pprv (PVHProp) = ppr_name hpropConName +ppr_name = text . symbolString + +instance PPrint RTyVar where + pprint (RTV α) + | ppTyVar ppEnv = ppr_tyvar α + | otherwise = ppr_tyvar_short α + +ppr_tyvar = text . tvId +ppr_tyvar_short = text . showPpr + +instance (Reftable s, PPrint s, PPrint p, Reftable p, PPrint t, PPrint (RType a b c p)) => PPrint (Ref t s (RType a b c p)) where + pprint (RPropP ss s) = ppRefArgs (fst <$> ss) <+> pprint s + pprint (RProp ss s) = ppRefArgs (fst <$> ss) <+> pprint (fromMaybe mempty (stripRTypeBase s)) + +ppRefArgs [] = empty +ppRefArgs ss = text "\\" <> hsep (ppRefSym <$> ss ++ [vv Nothing]) <+> text "->" + +ppRefSym "" = text "_" +ppRefSym s = pprint s + +instance (PPrint r, Reftable r) => PPrint (UReft r) where + pprint (U r p s) + | isTauto r = pprint p + | isTauto p = pprint r + | otherwise = pprint p <> text " & " <> pprint r + +pprintLongList :: PPrint a => [a] -> Doc +pprintLongList = brackets . vcat . map pprint + + + +instance (PPrint t) => PPrint (Annot t) where + pprint (AnnUse t) = text "AnnUse" <+> pprint t + pprint (AnnDef t) = text "AnnDef" <+> pprint t + pprint (AnnRDf t) = text "AnnRDf" <+> pprint t + pprint (AnnLoc l) = text "AnnLoc" <+> pprDoc l + +pprAnnInfoBinds (l, xvs) + = vcat $ map (pprAnnInfoBind . (l,)) xvs + +pprAnnInfoBind (RealSrcSpan k, xv) + = xd $$ pprDoc l $$ pprDoc c $$ pprint n $$ vd $$ text "\n\n\n" + where + l = srcSpanStartLine k + c = srcSpanStartCol k + (xd, vd) = pprXOT xv + n = length $ lines $ render vd + +pprAnnInfoBind (_, _) + = empty + +pprXOT (x, v) = (xd, pprint v) + where + xd = maybe (text "unknown") pprint x + +instance PPrint a => PPrint (AnnInfo a) where + pprint (AI m) = vcat $ map pprAnnInfoBinds $ M.toList m + +instance (Ord k, PPrint k, PPrint v) => PPrint (M.HashMap k v) where + pprint = ppTable + +ppTable m = vcat $ pprxt <$> xts + where + pprxt (x,t) = pprint x $$ nest n (colon <+> pprint t) + n = 1 + maximum [ i | (x, _) <- xts, let i = keySize x, i <= thresh ] + keySize = length . render . pprint + xts = sortBy (compare `on` fst) $ M.toList m + thresh = 6 + + + diff --git a/src/Language/Haskell/Liquid/Qualifier.hs b/src/Language/Haskell/Liquid/Qualifier.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Qualifier.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Language.Haskell.Liquid.Qualifier ( + specificationQualifiers + ) where + +import IdInfo (IdDetails(..)) +import Var (idDetails) + +import Language.Haskell.Liquid.Bare +import Language.Haskell.Liquid.RefType +import Language.Haskell.Liquid.GhcInterface +import Language.Haskell.Liquid.GhcMisc (getSourcePos) +import Language.Haskell.Liquid.PredType +import Language.Haskell.Liquid.Types +import Language.Fixpoint.Types +import Language.Fixpoint.Misc + +import Control.Applicative ((<$>)) +import Data.List (delete, nub) +import Data.Maybe (fromMaybe) +import qualified Data.HashSet as S +import qualified Data.Text as T +import Data.Bifunctor (second) + +----------------------------------------------------------------------------------- +specificationQualifiers :: Int -> GhcInfo -> [Qualifier] +----------------------------------------------------------------------------------- +specificationQualifiers k info + = [ q | (x, t) <- (tySigs $ spec info) ++ (asmSigs $ spec info) + -- FIXME: this mines extra, useful qualifiers but causes a significant increase in running time + -- , ((isClassOp x || isDataCon x) && x `S.member` (S.fromList $ impVars info ++ defVars info)) || x `S.member` (S.fromList $ defVars info) + , x `S.member` (S.fromList $ defVars info) + , q <- refTypeQuals (getSourcePos x) (tcEmbeds $ spec info) (val t) + , length (q_params q) <= k + 1 + ] + where + isClassOp (idDetails -> ClassOpId _) = True + isClassOp _ = False + isDataCon (idDetails -> DataConWorkId _) = True + isDataCon (idDetails -> DataConWrapId _) = True + isDataCon _ = False + + +-- GRAVEYARD: scraping quals from imports kills the system with too much crap +-- specificationQualifiers info = {- filter okQual -} qs +-- where +-- qs = concatMap refTypeQualifiers ts +-- refTypeQualifiers = refTypeQuals $ tcEmbeds spc +-- ts = val <$> t1s ++ t2s +-- t1s = [t | (x, t) <- tySigs spc, x `S.member` definedVars] +-- t2s = [] -- [t | (_, t) <- ctor spc ] +-- definedVars = S.fromList $ defVars info +-- spc = spec info +-- +-- okQual = not . any isPred . map snd . q_params +-- where +-- isPred (FApp tc _) = tc == stringFTycon "Pred" +-- isPred _ = False + + +refTypeQuals l tce t = quals ++ pAppQuals l tce preds quals + where + quals = refTypeQuals' l tce t + preds = filter isPropPV $ ty_preds $ toRTypeRep t + +pAppQuals l tce ps qs = [ pAppQual l tce p xs (v, e) | p <- ps, (s, v, _) <- pargs p, (xs, e) <- mkE s ] + where + mkE s = concatMap (expressionsOfSort (rTypeSort tce s)) qs + +expressionsOfSort sort (Q _ pars (PAtom Eq (EVar v) e2) _) + | (v, sort) `elem` pars + = [(filter (/=(v, sort)) pars, e2)] + +expressionsOfSort _ _ + = [] + +pAppQual l tce p args (v, expr) = Q "Auto" freeVars pred l + where + freeVars = (vv, tyvv) : (predv, typred) : args + pred = pApp predv $ EVar vv:predArgs + vv = "v" + predv = "~P" + tyvv = rTypeSort tce $ pvType p + typred = rTypeSort tce (pvarRType p :: RSort) + predArgs = mkexpr <$> (snd3 <$> pargs p) + mkexpr x = if x == v then expr else EVar x + +-- refTypeQuals :: SpecType -> [Qualifier] +refTypeQuals' l tce t0 = go emptySEnv t0 + where + go γ t@(RVar _ _) = refTopQuals l tce t0 γ t + go γ (RAllT _ t) = go γ t + go γ (RAllP _ t) = go γ t + go γ t@(RAppTy t1 t2 r) = go γ t1 ++ go γ t2 ++ refTopQuals l tce t0 γ t + go γ (RFun x t t' _) = (go γ t) + ++ (go (insertSEnv x (rTypeSort tce t) γ) t') + go γ t@(RApp c ts rs _) = (refTopQuals l tce t0 γ t) + ++ concatMap (go (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ)) ts + ++ goRefs c (insertSEnv (rTypeValueVar t) (rTypeSort tce t) γ) rs + go γ (RAllE x t t') = (go γ t) + ++ (go (insertSEnv x (rTypeSort tce t) γ) t') + go γ (REx x t t') = (go γ t) + ++ (go (insertSEnv x (rTypeSort tce t) γ) t') + go _ _ = [] + goRefs c g rs = concat $ zipWith (goRef g) rs (rTyConPVs c) + goRef g (RProp s t) _ = go (insertsSEnv g s) t + goRef _ (RPropP _ _) _ = [] + insertsSEnv = foldr (\(x, t) γ -> insertSEnv x (rTypeSort tce t) γ) + +refTopQuals l tce t0 γ t + = [ mkQual l t0 γ v so pa | let (RR so (Reft (v, ras))) = rTypeSortedReft tce t + , RConc p <- ras + , pa <- atoms p + ] ++ + [ mkPQual l tce t0 γ s e | let (U _ (Pr ps) _) = fromMaybe (msg t) $ stripRTypeBase t + , p <- (findPVar (ty_preds $ toRTypeRep t0)) <$> ps + , (s, _, e) <- pargs p + ] + where + msg t = errorstar $ "Qualifier.refTopQuals: no typebase" ++ showpp t + +mkPQual l tce t0 γ t e = mkQual l t0 γ' v so pa + where + v = "vv" + so = rTypeSort tce t + γ' = insertSEnv v so γ + pa = PAtom Eq (EVar v) e + +mkQual l t0 γ v so p = Q "Auto" ((v, so) : yts) p' l + where + yts = [(y, lookupSort t0 x γ) | (x, y) <- xys ] + p' = subst (mkSubst (second EVar <$> xys)) p + xys = zipWith (\x i -> (x, symbol ("~A" ++ show i))) xs [0..] + xs = delete v $ orderedFreeVars γ p + +lookupSort t0 x γ = fromMaybe (errorstar msg) $ lookupSEnv x γ + where + msg = "Unknown freeVar " ++ show x ++ " in specification " ++ show t0 + +orderedFreeVars γ = nub . filter (`memberSEnv` γ) . syms + +atoms (PAnd ps) = concatMap atoms ps +atoms p = [p] + + diff --git a/src/Language/Haskell/Liquid/RefType.hs b/src/Language/Haskell/Liquid/RefType.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/RefType.hs @@ -0,0 +1,1139 @@ +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternGuards #-} + +-- | Refinement Types. Mostly mirroring the GHC Type definition, but with +-- room for refinements of various sorts. + +-- TODO: Desperately needs re-organization. +module Language.Haskell.Liquid.RefType ( + + -- * Functions for lifting Reft-values to Spec-values + uTop, uReft, uRType, uRType', uRTypeGen, uPVar + + -- * Applying a solution to a SpecType + , applySolution + + -- * Functions for decreasing arguments + , isDecreasing, makeDecrType + , makeLexRefa + + -- * Functions for manipulating `Predicate`s + , pdVar + , findPVar + , freeTyVars, tyClasses, tyConName + + -- TODO: categorize these! + , ofType, ofPredTree, toType + , rTyVar, rVar, rApp, rEx + , addTyConInfo + -- , expandRApp + , appRTyCon + , typeSort, typeUniqueSymbol + , strengthen + , generalize, normalizePds + , subts, subvPredicate, subvUReft + , subsTyVar_meet, subsTyVars_meet, subsTyVar_nomeet, subsTyVars_nomeet + , dataConSymbol, dataConMsReft, dataConReft + , literalFRefType, literalFReft, literalConst + , classBinds + + -- * Manipulating Refinements in RTypes + , rTypeSortedReft + , rTypeSort + , shiftVV + + , mkDataConIdsTy + , mkTyConInfo + ) where + +import WwLib +import FamInstEnv (emptyFamInstEnv) +import Var +import Literal +import GHC hiding (Located) +import DataCon +import PrelInfo (isNumericClass) +import qualified TyCon as TC +import TypeRep hiding (maybeParen, pprArrowChain) +import Type (mkClassPred, splitFunTys, expandTypeSynonyms, isPredTy, substTyWith, classifyPredType, PredTree(..), isClassPred) +import TysWiredIn (listTyCon, intDataCon, trueDataCon, falseDataCon) + +import qualified Data.Text as T +import Data.Interned +import Data.Monoid hiding ((<>)) +import Data.Maybe (fromMaybe, isJust) +import Data.Hashable +import Data.Aeson +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import Data.Function (on) +import Control.Applicative hiding (empty) +import Control.DeepSeq +import Control.Monad (liftM, liftM2, liftM3, void) +import Control.Exception (Exception (..)) +import qualified Data.Foldable as Fold +import Text.Printf +import Text.PrettyPrint.HughesPJ +import Text.Parsec.Pos (SourcePos) + +import Language.Haskell.Liquid.PrettyPrint +import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Types hiding (shiftVV, Predicate) +import Language.Haskell.Liquid.Types hiding (R, DataConP (..), sort) +import Language.Haskell.Liquid.World + +import Language.Haskell.Liquid.Misc +import Language.Fixpoint.Misc +import Language.Haskell.Liquid.GhcMisc (pprDoc, sDocDoc, typeUniqueString, tracePpr, tvId, getDataConVarUnique, showSDoc, showPpr, showSDocDump) +import Language.Fixpoint.Names (dropModuleNames, symSepName, funConName, listConName, tupConName) +import Data.List (sort, isSuffixOf, foldl') + +pdVar v = Pr [uPVar v] + +findPVar :: [PVar (RType p c tv ())] -> UsedPVar -> PVar (RType p c tv ()) +findPVar ps p + = PV name ty v (zipWith (\(_, _, e) (t, s, _) -> (t, s, e)) (pargs p) args) + where PV name ty v args = fromMaybe (msg p) $ L.find ((== pname p) . pname) ps + msg p = errorstar $ "RefType.findPVar" ++ showpp p ++ "not found" + +-- | Various functions for converting vanilla `Reft` to `Spec` + +uRType :: RType p c tv a -> RType p c tv (UReft a) +uRType = fmap uTop + +uRType' :: RType p c tv (UReft a) -> RType p c tv a +uRType' = fmap ur_reft + +uRTypeGen :: Reftable b => RType p c tv a -> RType p c tv b +uRTypeGen = fmap $ const mempty + +uPVar :: PVar t -> UsedPVar +uPVar = void -- fmap (const ()) + +uReft :: (Symbol, [Refa]) -> UReft Reft +uReft = uTop . Reft + +uTop :: r -> UReft r +uTop r = U r mempty mempty + +-------------------------------------------------------------------- +-------------- (Class) Predicates for Valid Refinement Types ------- +-------------------------------------------------------------------- + +-- Monoid Instances --------------------------------------------------------- + + +instance ( SubsTy tv (RType p c tv ()) (RType p c tv ()) + , SubsTy tv (RType p c tv ()) c + , RefTypable p c tv () + , RefTypable p c tv r + , PPrint (RType p c tv r) + ) + => Monoid (RType p c tv r) where + mempty = errorstar "mempty: RType" + mappend = strengthenRefType + +-- MOVE TO TYPES +instance ( SubsTy tv (RType p c tv ()) (RType p c tv ()) + , SubsTy tv (RType p c tv ()) c + , Reftable r + , RefTypable p c tv () + , RefTypable p c tv (UReft r)) + => Monoid (Ref (RType p c tv ()) r (RType p c tv (UReft r))) where + mempty = errorstar "mempty: RType 2" + mappend _ _ = errorstar "mappend: RType 2" + +instance ( Monoid r, Reftable r, RefTypable a b c r, RefTypable a b c ()) => Monoid (RTProp a 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 ++ s2) $ r1 `meet` r2 + + mappend (RProp s1 t1) (RProp s2 t2) + | isTrivial t1 = RProp s2 t2 + | isTrivial t2 = RProp s1 t1 + | otherwise = RProp (s1 ++ s2) $ t1 `strengthenRefType` t2 + +instance (Reftable r, RefTypable p c tv r, RefTypable p c tv ()) => Reftable (RTProp p c tv r) where + isTauto (RPropP _ r) = isTauto r + isTauto (RProp _ t) = isTrivial t + top (RProp xs t) = RProp xs $ mapReft top t + ppTy (RPropP _ r) d = ppTy r d + ppTy (RProp _ _) _ = errorstar "RefType: Reftable ppTy in RProp" + toReft = errorstar "RefType: Reftable toReft" + params = errorstar "RefType: Reftable params for Ref" + bot = errorstar "RefType: Reftable bot for Ref" + + +---------------------------------------------------------------------------- +-- | Subable Instances ----------------------------------------------------- +---------------------------------------------------------------------------- + +instance Subable (RRProp Reft) where + syms (RPropP ss r) = (fst <$> ss) ++ syms r + syms (RProp ss t) = (fst <$> ss) ++ syms t + syms _ = error "TODO:EFFECTS" + + subst su (RPropP ss r) = RPropP (mapSnd (subst su) <$> ss) $ subst su r + subst su (RProp ss r) = RProp (mapSnd (subst su) <$> ss) $ subst su r + subst _ _ = error "TODO:EFFECTS" + + substf f (RPropP ss r) = RPropP (mapSnd (substf f) <$> ss) $ substf f r + substf f (RProp ss r) = RProp (mapSnd (substf f) <$> ss) $ substf f r + substa f (RPropP ss r) = RPropP (mapSnd (substa f) <$> ss) $ substa f r + substa f (RProp ss r) = RProp (mapSnd (substa f) <$> ss) $ substa f r + substa f _ = error "TODO:EFFECTS" + +------------------------------------------------------------------------------- +-- | Reftable Instances ------------------------------------------------------- +------------------------------------------------------------------------------- + +instance (PPrint r, Reftable r) => Reftable (RType Class RTyCon RTyVar r) where + isTauto = isTrivial + ppTy = errorstar "ppTy RProp Reftable" + toReft = errorstar "toReft on RType" + params = errorstar "params on RType" + bot = errorstar "bot on RType" + + +------------------------------------------------------------------------------- +-- | TyConable Instances ------------------------------------------------------- +------------------------------------------------------------------------------- + +-- MOVE TO TYPES +instance TyConable RTyCon where + isFun = isFunTyCon . rtc_tc + isList = (listTyCon ==) . rtc_tc + isTuple = TC.isTupleTyCon . rtc_tc + ppTycon = toFix + +-- MOVE TO TYPES +instance TyConable Symbol where + isFun s = funConName == s + isList s = listConName == s + isTuple s = tupConName == s + ppTycon = text . symbolString + +instance TyConable LocSymbol where + isFun = isFun . val + isList = isList . val + isTuple = isTuple . val + ppTycon = ppTycon . val + + +------------------------------------------------------------------------------- +-- | RefTypable Instances ----------------------------------------------------- +------------------------------------------------------------------------------- + +-- MOVE TO TYPES +instance Fixpoint String where + toFix = text + +-- MOVE TO TYPES +instance Fixpoint Class where + toFix = text . showPpr + +-- MOVE TO TYPES +instance (Eq p, PPrint p, TyConable c, Reftable r, PPrint r) => RefTypable p c Symbol r where + ppCls = ppClassSymbol + ppRType = ppr_rtype ppEnv + +-- MOVE TO TYPES +instance (Reftable r, PPrint r) => RefTypable Class RTyCon RTyVar r where + ppCls = ppClassClassPred + ppRType = ppr_rtype ppEnv + +-- MOVE TO TYPES +class FreeVar a v where + freeVars :: a -> [v] + +-- MOVE TO TYPES +instance FreeVar RTyCon RTyVar where + freeVars = (RTV <$>) . tyConTyVars . rtc_tc + +-- MOVE TO TYPES +instance FreeVar LocSymbol Symbol where + freeVars _ = [] + +ppClassSymbol c _ = pprint c <+> text "..." +ppClassClassPred c ts = sDocDoc $ pprClassPred c (toType <$> ts) + +-- Eq Instances ------------------------------------------------------ + +-- MOVE TO TYPES +instance (RefTypable p c tv ()) => Eq (RType p c tv ()) where + (==) = eqRSort M.empty + +eqRSort m (RAllP _ t) (RAllP _ t') + = eqRSort m t t' +eqRSort m (RAllS _ t) (RAllS _ t') + = eqRSort m t t' +eqRSort m (RAllP _ t) t' + = eqRSort m t t' +eqRSort m (RAllT a t) (RAllT a' t') + | a == a' + = eqRSort m t t' + | otherwise + = eqRSort (M.insert a' a m) t t' +eqRSort m (RFun _ t1 t2 _) (RFun _ t1' t2' _) + = eqRSort m t1 t1' && eqRSort m t2 t2' +eqRSort m (RAppTy t1 t2 _) (RAppTy t1' t2' _) + = eqRSort m t1 t1' && eqRSort m t2 t2' +eqRSort m (RApp c ts _ _) (RApp c' ts' _ _) + = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts') +eqRSort m (RCls c ts) (RCls c' ts') + = c == c' && length ts == length ts' && and (zipWith (eqRSort m) ts ts') +eqRSort m (RVar a _) (RVar a' _) + = a == M.lookupDefault a' a' m +eqRSort _ (RHole _) _ + = True +eqRSort _ _ (RHole _) + = True +eqRSort _ _ _ + = False + +-------------------------------------------------------------------- +-- | Wrappers for GHC Type Elements -------------------------------- +-------------------------------------------------------------------- + +instance Eq Predicate where + (==) = eqpd + +eqpd (Pr vs) (Pr ws) + = and $ (length vs' == length ws') : [v == w | (v, w) <- zip vs' ws'] + where vs' = sort vs + ws' = sort ws + + +instance Eq RTyVar where + RTV α == RTV α' = tvId α == tvId α' + +instance Ord RTyVar where + compare (RTV α) (RTV α') = compare (tvId α) (tvId α') + +instance Hashable RTyVar where + hashWithSalt i (RTV α) = hashWithSalt i α + +instance Ord RTyCon where + compare x y = compare (rtc_tc x) (rtc_tc y) + +instance Eq RTyCon where + x == y = rtc_tc x == rtc_tc y + +instance Hashable RTyCon where + hashWithSalt i = hashWithSalt i . rtc_tc + +-------------------------------------------------------------------- +---------------------- Helper Functions ---------------------------- +-------------------------------------------------------------------- + +rVar = (`RVar` mempty) . RTV +rTyVar = RTV + +normalizePds t = addPds ps t' + where (t', ps) = nlzP [] t + +rPred = RAllP +rEx xts t = foldr (\(x, tx) t -> REx x tx t) t xts +rApp c = RApp (RTyCon c [] (mkTyConInfo c [] [] Nothing)) + + + +addPds ps (RAllT v t) = RAllT v $ addPds ps t +addPds ps t = foldl' (flip rPred) t ps + +nlzP ps t@(RVar _ _ ) + = (t, ps) +nlzP ps (RFun b t1 t2 r) + = (RFun b t1' t2' r, ps ++ ps1 ++ ps2) + where (t1', ps1) = nlzP [] t1 + (t2', ps2) = nlzP [] t2 +nlzP ps (RAppTy t1 t2 r) + = (RAppTy t1' t2' r, ps ++ ps1 ++ ps2) + where (t1', ps1) = nlzP [] t1 + (t2', ps2) = nlzP [] t2 +nlzP ps (RAllT v t ) + = (RAllT v t', ps ++ ps') + where (t', ps') = nlzP [] t +nlzP ps t@(RApp _ _ _ _) + = (t, ps) +nlzP ps (RAllS _ t) + = (t, ps) +nlzP ps t@(RCls _ _) + = (t, ps) +nlzP ps (RAllP p t) + = (t', [p] ++ ps ++ ps') + where (t', ps') = nlzP [] t +nlzP ps t@(ROth _) + = (t, ps) +nlzP ps t@(REx _ _ _) + = (t, ps) +nlzP ps t@(RRTy _ _ _ t') + = (t, ps ++ ps') + where ps' = snd $ nlzP [] t' +nlzP ps t@(RAllE _ _ _) + = (t, ps) +nlzP _ t + = errorstar $ "RefType.nlzP: cannot handle " ++ show t + +-- 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 + | otherwise + = errorstar msg + where + eqt t1 t2 = {- render -} toRSort t1 == {- render -} toRSort t2 + msg = printf "strengthen on differently shaped reftypes \nt1 = %s [shape = %s]\nt2 = %s [shape = %s]" + (showpp t1) (showpp (toRSort t1)) (showpp t2) (showpp (toRSort t2)) + +unifyShape :: ( RefTypable p c tv r + , FreeVar c tv + , RefTypable p c tv () + , SubsTy tv (RType p c tv ()) (RType p c tv ()) + , SubsTy tv (RType p c tv ()) c) + => RType p c tv r -> RType p c tv r -> Maybe (RType p c tv r) + +unifyShape (RAllT a1 t1) (RAllT a2 t2) + | a1 == a2 = RAllT a1 <$> unifyShape t1 t2 + | otherwise = RAllT a1 <$> unifyShape t1 (sub a2 a1 t2) + where sub a b = let bt = RVar b mempty in subsTyVar_meet (a, toRSort bt, bt) + +unifyShape t1 t2 + | eqt t1 t2 = Just t1 + | otherwise = Nothing + where eqt t1 t2 = showpp (toRSort t1) == showpp (toRSort t2) + +-- strengthenRefType_ :: RefTypable p c tv r =>RType p c tv r -> RType p c tv r -> RType p c tv r +strengthenRefType_ (RAllT a1 t1) (RAllT _ t2) + = RAllT a1 $ strengthenRefType_ t1 t2 + +strengthenRefType_ (RAllP p1 t1) (RAllP _ t2) + = RAllP p1 $ strengthenRefType_ t1 t2 + +strengthenRefType_ (RAllS s t1) t2 + = RAllS s $ strengthenRefType_ t1 t2 + +strengthenRefType_ t1 (RAllS s t2) + = RAllS s $ strengthenRefType_ t1 t2 + +strengthenRefType_ (RAppTy t1 t1' r1) (RAppTy t2 t2' r2) + = RAppTy t t' (r1 `meet` r2) + where t = strengthenRefType_ t1 t2 + t' = strengthenRefType_ t1' t2' + +strengthenRefType_ (RFun x1 t1 t1' r1) (RFun x2 t2 t2' r2) + = RFun x1 t t' (r1 `meet` r2) + where t = strengthenRefType_ t1 t2 + t' = strengthenRefType_ t1' $ subst1 t2' (x2, EVar x1) + +strengthenRefType_ (RApp tid t1s rs1 r1) (RApp _ t2s rs2 r2) + = RApp tid ts rs (r1 `meet` r2) + where ts = zipWith strengthenRefType_ t1s t2s + rs = {- tracePpr msg $ -} meets rs1 rs2 + msg = "strengthenRefType_: RApp rs1 = " ++ showpp rs1 ++ " rs2 = " ++ showpp rs2 + + +strengthenRefType_ (RVar v1 r1) (RVar _ r2) + = RVar v1 ({- tracePpr msg $ -} r1 `meet` r2) + where msg = "strengthenRefType_: RVAR r1 = " ++ showpp r1 ++ " r2 = " ++ showpp r2 + +strengthenRefType_ t1 _ + = t1 + +meets [] rs = rs +meets rs [] = rs +meets rs rs' + | length rs == length rs' = zipWith meet rs rs' + | otherwise = errorstar "meets: unbalanced rs" + + +strengthen :: Reftable r => RType p c tv r -> r -> RType p c tv r +strengthen (RApp c ts rs r) r' = RApp c ts rs (r `meet` r') +strengthen (RVar a r) r' = RVar a (r `meet` r') +strengthen (RFun b t1 t2 r) r' = RFun b t1 t2 (r `meet` r') +strengthen (RAppTy t1 t2 r) r' = RAppTy t1 t2 (r `meet` r') +strengthen t _ = t + + + +------------------------------------------------------------------------- +addTyConInfo :: (PPrint r, Reftable r) + => (M.HashMap TyCon FTycon) + -> (M.HashMap TyCon RTyCon) + -> RRType r + -> RRType r +------------------------------------------------------------------------- +addTyConInfo tce tyi = mapBot (expandRApp tce tyi) + +------------------------------------------------------------------------- +expandRApp :: (PPrint r, Reftable r) + => (M.HashMap TyCon FTycon) + -> (M.HashMap TyCon RTyCon) + -> RRType r + -> RRType r +------------------------------------------------------------------------- +expandRApp tce tyi t@(RApp {}) = RApp rc' ts rs' r + where + RApp rc ts rs r = t + rc' = appRTyCon tce tyi rc ts + pvs = rTyConPVs rc' + rs' = applyNonNull rs0 (rtPropPV rc pvs) rs + rs0 = rtPropTop <$> pvs + +expandRApp _ _ t = t + +rtPropTop pv = case ptype pv of + PVProp t -> RProp xts $ ofRSort t + PVHProp -> RProp xts $ mempty + where + xts = pvArgs pv + +rtPropPV rc = safeZipWith msg mkRTProp + where + msg = "appRefts: " ++ showFix rc + +mkRTProp pv (RPropP ss r) + = RProp ss $ (ofRSort $ pvType pv) `strengthen` r + +mkRTProp pv (RProp ss t) + | length (pargs pv) == length ss + = RProp ss t + | otherwise + = RProp (pvArgs pv) t + +mkRTProp pv (RHProp ss w) + | length (pargs pv) == length ss + = RHProp ss w + | otherwise + = RHProp (pvArgs pv) w + +pvArgs pv = [(s, t) | (t, s, _) <- pargs pv] + + +appRTyCon tce tyi rc ts = RTyCon c ps' (rtc_info rc'') + where + c = rtc_tc rc + ps' = subts (zip (RTV <$> αs) ts') <$> rTyConPVs rc' + ts' = if null ts then rVar <$> βs else toRSort <$> ts + rc' = M.lookupDefault rc c tyi + αs = TC.tyConTyVars $ rtc_tc rc' + βs = TC.tyConTyVars c + rc'' = if isNumeric tce rc' then addNumSizeFun rc' else rc' + +isNumeric tce c + = fromMaybe (symbolFTycon . dummyLoc $ tyConName (rtc_tc c)) + (M.lookup (rtc_tc c) tce) == intFTyCon + +addNumSizeFun c + = c {rtc_info = (rtc_info c) {sizeFunction = Just EVar} } + + +generalize :: (RefTypable c p tv r) => RType c p tv r -> RType c p tv r +generalize t = mkUnivs (freeTyVars t) [] [] t + +freeTyVars (RAllP _ t) = freeTyVars t +freeTyVars (RAllS _ t) = freeTyVars t +freeTyVars (RAllT α t) = freeTyVars t L.\\ [α] +freeTyVars (RFun _ t t' _) = freeTyVars t `L.union` freeTyVars t' +freeTyVars (RApp _ ts _ _) = L.nub $ concatMap freeTyVars ts +freeTyVars (RCls _ ts) = [] +freeTyVars (RVar α _) = [α] +freeTyVars (RAllE _ _ t) = freeTyVars t +freeTyVars (REx _ _ t) = freeTyVars t +freeTyVars (RExprArg _) = [] +freeTyVars (RAppTy t t' _) = freeTyVars t `L.union` freeTyVars t' +freeTyVars (RHole r) = [] +freeTyVars t = errorstar ("RefType.freeTyVars cannot handle" ++ show t) + + +tyClasses (RAllP _ t) = tyClasses t +tyClasses (RAllS _ t) = tyClasses t +tyClasses (RAllT α t) = tyClasses t +tyClasses (RAllE _ _ t) = tyClasses t +tyClasses (REx _ _ t) = tyClasses t +tyClasses (RFun _ t t' _) = tyClasses t ++ tyClasses t' +tyClasses (RAppTy t t' _) = tyClasses t ++ tyClasses t' +tyClasses (RApp _ ts _ _) = concatMap tyClasses ts +tyClasses (RCls c ts) = (c, ts) : concatMap tyClasses ts +tyClasses (RVar α _) = [] +tyClasses (RRTy _ _ _ t) = tyClasses t +tyClasses (RHole r) = [] +tyClasses t = errorstar ("RefType.tyClasses cannot handle" ++ show t) + + + +--getTyClasses = everything (++) ([] `mkQ` f) +-- where f ((RCls c ts) :: SpecType) = [(c, ts)] +-- f _ = [] + + + +---------------------------------------------------------------- +---------------------- Strictness ------------------------------ +---------------------------------------------------------------- + +instance (NFData a, NFData b, NFData t) => NFData (Ref t a b) where + rnf (RPropP s a) = rnf s `seq` rnf a + rnf (RProp s b) = rnf s `seq` rnf b + +instance (NFData a, NFData b, NFData c, NFData e) => NFData (RType a b c e) where + rnf (RVar α r) = rnf α `seq` rnf r + rnf (RAllT α t) = rnf α `seq` rnf t + rnf (RAllP π t) = rnf π `seq` rnf t + rnf (RAllS s t) = rnf s `seq` rnf t + rnf (RFun x t t' r) = rnf x `seq` rnf t `seq` rnf t' `seq` rnf r + rnf (RApp _ ts rs r) = rnf ts `seq` rnf rs `seq` rnf r + rnf (RCls c ts) = c `seq` rnf ts + rnf (RAllE x t t') = rnf x `seq` rnf t `seq` rnf t' + rnf (REx x t t') = rnf x `seq` rnf t `seq` rnf t' + rnf (ROth s) = rnf s + rnf (RExprArg e) = rnf e + rnf (RAppTy t t' r) = rnf t `seq` rnf t' `seq` rnf r + rnf (RRTy _ r o t) = rnf r `seq` rnf t + rnf (RHole r) = rnf r + +---------------------------------------------------------------- +------------------ Printing Refinement Types ------------------- +---------------------------------------------------------------- + +instance Show RTyVar where + show = showpp + +instance PPrint (UReft r) => Show (UReft r) where + show = showpp + +-- instance (Fixpoint a, Fixpoint b, Fixpoint c) => Fixpoint (a, b, c) where +-- toFix (a, b, c) = hsep ([toFix a ,toFix b, toFix c]) + +instance (RefTypable p c tv r) => PPrint (RType p c tv r) where + pprint = ppRType TopPrec + +instance PPrint (RType p c tv r) => Show (RType p c tv r) where + show = showpp + +instance PPrint (RTProp p c tv r) => Show (RTProp p c tv r) where + show = showpp + +instance Fixpoint RTyCon where + toFix (RTyCon c _ _) = text $ showPpr c -- <+> text "\n<<" <+> hsep (map toFix ts) <+> text ">>\n" + +instance PPrint RTyCon where + pprint = toFix + +instance Show RTyCon where + show = showpp + +instance PPrint REnv where + pprint (REnv m) = pprint m + +------------------------------------------------------------------------------------------ +-- TODO: Rewrite subsTyvars with Traversable +------------------------------------------------------------------------------------------ + +subsTyVars_meet = subsTyVars True +subsTyVars_nomeet = subsTyVars False +subsTyVar_nomeet = subsTyVar False +subsTyVar_meet = subsTyVar True +subsTyVars meet ats t = foldl' (flip (subsTyVar meet)) t ats +subsTyVar meet = subsFree meet S.empty + +--subsFree :: ( Ord tv +-- , SubsTy tv ty c +-- , SubsTy tv ty r +-- , SubsTy tv ty (PVar (RType p c tv ())) +-- , RefTypable p c tv r) +-- => Bool +-- -> S.Set tv +-- -> (tv, ty, RType p c tv r) +-- -> RType p c tv r +-- -> RType p c tv r +subsFree m s z@(α, τ,_) (RAllS l t) + = RAllS l (subsFree m s z t) +subsFree m s z@(α, τ,_) (RAllP π t) + = RAllP (subt (α, τ) π) (subsFree m s z t) +subsFree m s z (RAllT α t) + = RAllT α $ subsFree m (α `S.insert` s) z t +subsFree m s z@(_, _, _) (RFun x t t' r) + = RFun x (subsFree m s z t) (subsFree m s z t') r +subsFree m s z@(α, τ, _) (RApp c ts rs r) + = RApp (subt z' c) (subsFree m s z <$> ts) (subsFreeRef m s z <$> rs) r + where z' = (α, τ) -- UNIFY: why instantiating INSIDE parameters? +subsFree m s z (RCls c ts) + = RCls c (subsFree m s z <$> ts) +subsFree meet s (α', _, t') t@(RVar α r) + | α == α' && not (α `S.member` s) + = if meet then t' `strengthen` r else t' + | otherwise + = t +subsFree m s z (RAllE x t t') + = RAllE x (subsFree m s z t) (subsFree m s z t') +subsFree m s z (REx x t t') + = REx x (subsFree m s z t) (subsFree m s z t') +subsFree m s z@(_, _, _) (RAppTy t t' r) + = subsFreeRAppTy m s (subsFree m s z t) (subsFree m s z t') r +subsFree _ _ _ t@(RExprArg _) + = t +subsFree m s z (RRTy e r o t) + = RRTy (mapSnd (subsFree m s z) <$> e) r o (subsFree m s z t) +subsFree _ _ _ t@(ROth _) + = t +subsFree _ _ _ t@(RHole r) + = t +-- subsFree _ _ _ t +-- = errorstar $ "subsFree fails on: " ++ showFix t + +subsFrees m s zs t = foldl' (flip(subsFree m s)) t zs + +-- GHC INVARIANT: RApp is Type Application to something other than TYCon +subsFreeRAppTy m s (RApp c ts rs r) t' r' + = mkRApp m s c (ts ++ [t']) rs r r' +subsFreeRAppTy m s t t' r' + = RAppTy t t' r' + +mkRApp m s c ts rs r r' + | isFun c, [t1, t2] <- ts + = RFun dummySymbol t1 t2 $ refAppTyToFun r' + | otherwise + = subsFrees m s zs $ RApp c ts rs $ r `meet` r' -- (refAppTyToApp r') + where + zs = [(tv, toRSort t, t) | (tv, t) <- zip (freeVars c) ts] + +refAppTyToFun r + | isTauto r = r + | otherwise = errorstar "RefType.refAppTyToFun" + +subsFreeRef m s (α', τ', t') (RProp ss t) + = RProp (mapSnd (subt (α', τ')) <$> ss) $ subsFree m s (α', τ', fmap top t') t +subsFreeRef _ _ (α', τ', _) (RPropP ss r) + = RPropP (mapSnd (subt (α', τ')) <$> ss) $ {- subt (α', τ') -} r + +------------------------------------------------------------------- +------------------- Type Substitutions ---------------------------- +------------------------------------------------------------------- + +subts = flip (foldr subt) + +instance SubsTy tv ty () where + subt _ = id + +instance SubsTy tv ty Reft where + subt _ = id + +instance (SubsTy tv ty ty) => SubsTy tv ty (PVKind ty) where + subt su (PVProp t) = PVProp (subt su t) + subt su PVHProp = PVHProp + +instance (SubsTy tv ty ty) => SubsTy tv ty (PVar ty) where + subt su (PV n t v xts) = PV n (subt su t) v [(subt su t, x, y) | (t,x,y) <- xts] + +instance SubsTy RTyVar RSort RTyCon where + subt z c = RTyCon tc ps' i + where + tc = rtc_tc c + ps' = subt z <$> rTyConPVs c + i = rtc_info c + +-- NOTE: This DOES NOT substitute at the binders +instance SubsTy RTyVar RSort PrType where + subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) + +instance SubsTy RTyVar RSort SpecType where + subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) + +instance SubsTy RTyVar RTyVar SpecType where + subt (α, a) = subt (α, RVar a () :: RSort) + + +instance SubsTy RTyVar RSort RSort where + subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) + +-- Here the "String" is a Bare-TyCon. TODO: wrap in newtype +instance SubsTy Symbol BSort LocSymbol where + subt _ t = t + +instance SubsTy Symbol BSort BSort where + subt (α, τ) = subsTyVar_meet (α, τ, ofRSort τ) + +instance (SubsTy tv ty (UReft r), SubsTy tv ty (RType p c tv ())) => SubsTy tv ty (RTProp p c tv (UReft r)) where + subt m (RPropP ss p) = RPropP ((mapSnd (subt m)) <$> ss) $ subt m p + subt m (RProp ss t) = RProp ((mapSnd (subt m)) <$> ss) $ fmap (subt m) t + +subvUReft :: (UsedPVar -> UsedPVar) -> UReft Reft -> UReft Reft +subvUReft f (U r p s) = U r (subvPredicate f p) s + +subvPredicate :: (UsedPVar -> UsedPVar) -> Predicate -> Predicate +subvPredicate f (Pr pvs) = Pr (f <$> pvs) + +--------------------------------------------------------------- + +-- ofType, ofType_ :: Reftable r => Type -> RRType r +ofType = ofType_ . expandTypeSynonyms + +ofType_ (TyVarTy α) + = rVar α +ofType_ (FunTy τ τ') + = rFun dummySymbol (ofType_ τ) (ofType_ τ') +ofType_ (ForAllTy α τ) + = RAllT (rTyVar α) $ ofType_ τ +ofType_ τ + | Just t <- ofPredTree (classifyPredType τ) + = t +ofType_ (TyConApp c τs) + | Just (αs, τ) <- TC.synTyConDefn_maybe c + = ofType_ $ substTyWith αs τs τ + | otherwise + = rApp c (ofType_ <$> τs) [] mempty +ofType_ (AppTy t1 t2) + = RAppTy (ofType_ t1) (ofType t2) mempty +-- ofType_ τ +-- = errorstar ("ofType cannot handle: " ++ showPpr τ) + +ofPredTree (ClassPred c τs) + = Just $ RCls c (ofType_ <$> τs) +ofPredTree _ + = Nothing + +---------------------------------------------------------------- +------------------- Converting to Fixpoint --------------------- +---------------------------------------------------------------- + + +instance Expression Var where + expr = eVar + + + +pprShort = symbolString . dropModuleNames . symbol + +dataConSymbol :: DataCon -> Symbol +dataConSymbol = symbol . dataConWorkId + +-- TODO: turn this into a map lookup? +dataConReft :: DataCon -> [Symbol] -> Reft +dataConReft c [] + | c == trueDataCon + = Reft (vv_, [RConc $ eProp vv_]) + | c == falseDataCon + = Reft (vv_, [RConc $ PNot $ eProp vv_]) +dataConReft c [x] + | c == intDataCon + = Reft (vv_, [RConc (PAtom Eq (EVar vv_) (EVar x))]) +dataConReft c _ + | not $ isBaseDataCon c + = mempty +dataConReft c xs + = Reft (vv_, [RConc (PAtom Eq (EVar vv_) dcValue)]) + where dcValue | null xs && null (dataConUnivTyVars c) + = EVar $ dataConSymbol c + | otherwise + = EApp (dummyLoc $ dataConSymbol c) (EVar <$> xs) + +isBaseDataCon c = and $ isBaseTy <$> dataConOrigArgTys c ++ dataConRepArgTys c + +isBaseTy (TyVarTy _) = True +isBaseTy (AppTy t1 t2) = False +isBaseTy (TyConApp _ ts) = and $ isBaseTy <$> ts +isBaseTy (FunTy _ _) = False +isBaseTy (ForAllTy _ _) = False + + +vv_ = vv Nothing + +dataConMsReft ty ys = subst su (rTypeReft (ignoreOblig $ ty_res trep)) + where trep = toRTypeRep ty + xs = ty_binds trep + ts = ty_args trep + su = mkSubst $ [(x, EVar y) | ((x, _), y) <- zip (zip xs ts) ys] + +--------------------------------------------------------------- +---------------------- Embedding RefTypes --------------------- +--------------------------------------------------------------- +-- TODO: remove toType, generalize typeSort +toType :: (Reftable r, PPrint r) => RRType r -> Type +toType (RFun _ t t' _) + = FunTy (toType t) (toType t') +toType (RAllT (RTV α) t) + = ForAllTy α (toType t) +toType (RAllP _ t) + = toType t +toType (RAllS _ t) + = toType t +toType (RVar (RTV α) _) + = TyVarTy α +toType (RApp (RTyCon {rtc_tc = c}) ts _ _) + = TyConApp c (toType <$> ts) +toType (RCls c ts) + = mkClassPred c (toType <$> ts) +toType (RAllE _ _ t) + = toType t +toType (REx _ _ t) + = toType t +toType (RAppTy t t' _) + = AppTy (toType t) (toType t') +toType t@(RExprArg _) + = errorstar $ "RefType.toType cannot handle 1: " ++ show t +toType t@(ROth _) + = errorstar $ "RefType.toType cannot handle 2: " ++ show t +toType (RRTy _ _ _ t) + = toType t +toType t + = errorstar $ "RefType.toType cannot handle: " ++ show t + + +--------------------------------------------------------------- +----------------------- Typing Literals ----------------------- +--------------------------------------------------------------- + +-- makeRTypeBase :: Type -> Reft -> RefType +makeRTypeBase (TyVarTy α) x + = RVar (rTyVar α) x +makeRTypeBase (TyConApp c _) x + = rApp c [] [] x +makeRTypeBase _ _ + = error "RefType : makeRTypeBase" + +literalFRefType tce l + = makeRTypeBase (literalType l) (literalFReft tce l) + +literalFReft tce = maybe mempty exprReft . snd . literalConst tce + + -- exprReft . snd . literalConst tce + +-- | `literalConst` returns `Nothing` for unhandled lits because +-- otherwise string-literals show up as global int-constants +-- which blow up qualifier instantiation. + +literalConst tce l = (sort, mkLit l) + where + sort = typeSort tce $ literalType l + mkLit (MachInt n) = mkI n + mkLit (MachInt64 n) = mkI n + mkLit (MachWord n) = mkI n + mkLit (MachWord64 n) = mkI n + mkLit (MachFloat n) = mkR n + mkLit (MachDouble n) = mkR n + mkLit (LitInteger n _) = mkI n + mkLit _ = Nothing -- ELit sym sort + mkI = Just . ECon . I + mkR = Just . ECon . R . fromRational + +--------------------------------------------------------------- +---------------- Annotations and Solutions -------------------- +--------------------------------------------------------------- + +rTypeSortedReft :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> SortedReft +rTypeSortedReft emb t = RR (rTypeSort emb t) (rTypeReft t) + +rTypeSort :: (PPrint r, Reftable r) => TCEmb TyCon -> RRType r -> Sort +rTypeSort tce = typeSort tce . toType + +------------------------------------------------------------------------------- +applySolution :: (Functor f) => FixSolution -> f SpecType -> f SpecType +------------------------------------------------------------------------------- +applySolution = fmap . fmap . mapReft . map . appSolRefa + where + appSolRefa _ ra@(RConc _) = ra + -- appSolRefa _ p@(RPvar _) = p + appSolRefa s (RKvar k su) = RConc $ subst su $ M.lookupDefault PTop k s + mapReft f (U (Reft (x, zs)) p s) = U (Reft (x, squishRefas $ f zs)) p s + +------------------------------------------------------------------------------- +shiftVV :: SpecType -> Symbol -> SpecType +------------------------------------------------------------------------------- + +shiftVV t@(RApp _ ts _ r) vv' + = t { rt_args = subst1 ts (rTypeValueVar t, EVar vv') } + { rt_reft = (`F.shiftVV` vv') <$> r } + +shiftVV t@(RFun _ _ _ r) vv' + = t { rt_reft = (`F.shiftVV` vv') <$> r } + +shiftVV t@(RAppTy _ _ r) vv' + = t { rt_reft = (`F.shiftVV` vv') <$> r } + +shiftVV t@(RVar _ r) vv' + = t { rt_reft = (`F.shiftVV` vv') <$> r } + +shiftVV t _ + = t -- errorstar $ "shiftVV: cannot handle " ++ showpp t + + +------------------------------------------------------------------------ +---------------- Auxiliary Stuff Used Elsewhere ------------------------ +------------------------------------------------------------------------ + +-- MOVE TO TYPES +instance (Show tv, Show ty) => Show (RTAlias tv ty) where + show (RTA n as xs t p) = printf "type %s %s %s = %s -- defined at %s" (symbolString n) + (L.intercalate " " (show <$> as)) + (L.intercalate " " (show <$> xs)) + (show t) (show p) + +---------------------------------------------------------------- +------------ From Old Fixpoint --------------------------------- +---------------------------------------------------------------- + + +typeUniqueSymbol :: Type -> Symbol +typeUniqueSymbol = symbol . typeUniqueString + +typeSort :: TCEmb TyCon -> Type -> Sort +typeSort tce τ@(ForAllTy _ _) + = typeSortForAll tce τ +typeSort tce t@(FunTy τ1 τ2) + = typeSortFun tce t +typeSort tce (TyConApp c τs) + = fApp (Left $ tyConFTyCon tce c) (typeSort tce <$> τs) +typeSort tce (AppTy t1 t2) + = fApp (Right $ typeSort tce t1) [typeSort tce t2] +typeSort _ τ + = FObj $ typeUniqueSymbol τ + +tyConFTyCon tce c = fromMaybe (symbolFTycon $ dummyLoc $ tyConName c) (M.lookup c tce) + +typeSortForAll tce τ + = genSort $ typeSort tce tbody + where genSort (FFunc _ t) = FFunc n (sortSubst su <$> t) + genSort t = FFunc n [sortSubst su t] + (as, tbody) = splitForAllTys τ + su = M.fromList $ zip sas (FVar <$> [0..]) + sas = (typeUniqueSymbol . TyVarTy) <$> as + n = length as + +-- sortSubst su t@(FObj x) = fromMaybe t (M.lookup x su) +-- sortSubst su (FFunc n ts) = FFunc n (sortSubst su <$> ts) +-- sortSubst su (FApp c ts) = FApp c (sortSubst su <$> ts) +-- sortSubst _ t = t + +tyConName c + | listTyCon == c = listConName + | TC.isTupleTyCon c = tupConName + | otherwise = symbol c + +typeSortFun tce t -- τ1 τ2 + = FFunc 0 sos + where sos = typeSort tce <$> τs + τs = grabArgs [] t +grabArgs τs (FunTy τ1 τ2 ) + | not $ isClassPred τ1 = grabArgs (τ1:τs) τ2 + | otherwise = grabArgs τs τ2 +grabArgs τs τ = reverse (τ:τs) + + +mkDataConIdsTy (dc, t) = [expandProductType id t | id <- dataConImplicitIds dc] + +expandProductType x t + | ofType (varType x) == toRSort t = (x, t) + | otherwise = (x, t') + where t' = fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'} + τs = fst $ splitFunTys $ toType t + trep = toRTypeRep t + (xs', ts') = unzip $ concatMap mkProductTy $ zip3 τs (ty_binds trep) (ty_args trep) + +mkProductTy (τ, x, t) = maybe [(x, t)] f $ deepSplitProductType_maybe menv τ + where f = ((<$>) ((,) dummySymbol . ofType)) . third4 + menv = (emptyFamInstEnv, emptyFamInstEnv) + +-- Move to misc +forth4 (_, _, _, x) = x + +----------------------------------------------------------------------------------------- +-- | Binders generated by class predicates, typically for constraining tyvars (e.g. FNum) +----------------------------------------------------------------------------------------- + +classBinds (RCls c ts) + | isNumericClass c = [(rTyVarSymbol a, trueSortedReft FNum) | (RVar a _) <- ts] +classBinds _ = [] + +rTyVarSymbol (RTV α) = typeUniqueSymbol $ TyVarTy α + +----------------------------------------------------------------------------------------- +--------------------------- Termination Predicates -------------------------------------- +----------------------------------------------------------------------------------------- + +isDecreasing (RApp c _ _ _) + = isJust (sizeFunction (rtc_info c)) +isDecreasing _ + = False + +makeDecrType = mkDType [] [] + +mkDType xvs acc [(v, (x, t@(RApp c _ _ _)))] + = (x, ) $ t `strengthen` tr + where tr = uTop $ Reft (vv, [RConc $ pOr (r:acc)]) + r = cmpLexRef xvs (v', vv, f) + v' = symbol v + Just f = sizeFunction $ rtc_info c + vv = "vvRec" + +mkDType xvs acc ((v, (x, t@(RApp c _ _ _))):vxts) + = mkDType ((v', x, f):xvs) (r:acc) vxts + where r = cmpLexRef xvs (v', x, f) + v' = symbol v + Just f = sizeFunction $ rtc_info c + +cmpLexRef vxs (v, x, g) + = pAnd $ (PAtom Lt (g x) (g v)) : (PAtom Ge (g x) zero) + : [PAtom Eq (f y) (f z) | (y, z, f) <- vxs] + ++ [PAtom Ge (f y) zero | (y, _, f) <- vxs] + where zero = ECon $ I 0 + +makeLexRefa es' es = uTop $ Reft (vv, [RConc $ PIff (PBexp $ EVar vv) $ pOr rs]) + where rs = makeLexReft [] [] es es' + vv = "vvRec" + +makeLexReft old acc [] [] + = acc +makeLexReft old acc (e:es) (e':es') + = makeLexReft ((e,e'):old) (r:acc) es es' + where + r = pAnd $ (PAtom Lt e' e) + : (PAtom Ge e' zero) + : [PAtom Eq o' o | (o,o') <- old] + ++ [PAtom Ge o' zero | (o,o') <- old] + zero = ECon $ I 0 + +------------------------------------------------------------------------------- + +mkTyConInfo :: TyCon -> [Int] -> [Int] -> (Maybe (Symbol -> Expr)) -> TyConInfo +mkTyConInfo c = TyConInfo pos neg + where pos = neutral ++ [i | (i, b) <- varsigns, b, i /= dindex] + neg = neutral ++ [i | (i, b) <- varsigns, not b, i /= dindex] + varsigns = L.nub $ concatMap goDCon $ TC.tyConDataCons c + initmap = zip (showPpr <$> tyvars) [0..n] + mkmap vs = zip (showPpr <$> vs) (repeat dindex) ++ initmap + goDCon dc = concatMap (go (mkmap (DataCon.dataConExTyVars dc)) True) + (DataCon.dataConOrigArgTys dc) + go m pos (ForAllTy v t) = go ((showPpr v, dindex):m) pos t + go m pos (TyVarTy v) = [(varLookup (showPpr v) m, pos)] + go m pos (AppTy t1 t2) = go m pos t1 ++ go m pos t2 + go m pos (TyConApp _ ts) = concatMap (go m pos) ts + go m pos (FunTy t1 t2) = go m (not pos) t1 ++ go m pos t2 + + varLookup v m = fromMaybe (errmsg v) $ L.lookup v m + tyvars = TC.tyConTyVars c + n = (TC.tyConArity c) - 1 + errmsg v = error $ "GhcMisc.getTyConInfo: var not found" ++ showPpr v + dindex = -1 + neutral = [0..n] L.\\ (fst <$> varsigns) + diff --git a/src/Language/Haskell/Liquid/Strata.hs b/src/Language/Haskell/Liquid/Strata.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Strata.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +module Language.Haskell.Liquid.Strata ( + SubStratum(..) + , solveStrata + , (<:=) + ) where + +import Control.Applicative ((<$>)) + +import Debug.Trace (trace) +import Language.Fixpoint.Misc +import Language.Fixpoint.Types (Symbol) +import Language.Haskell.Liquid.Types hiding (Def, Loc) + +s1 <:= s2 + | any (==SDiv) s1 && any (==SFin) s2 = False + | otherwise = True + +solveStrata = go True [] [] + where go False solved acc [] = solved + go True solved acc [] = go False solved [] $ {-traceShow ("OLD \n" ++ showMap solved acc ) $ -} subsS solved <$> acc + go mod solved acc (([], _):ls) = go mod solved acc ls + go mod solved acc ((_, []):ls) = go mod solved acc ls + go mod solved acc (l:ls) | allSVars l = go mod solved (l:acc) ls + | noSVar l = go mod solved acc ls + | noUpdate l = go mod solved (l:acc) ls + | otherwise = go True (solve l ++ solved) (l:acc) ls + +traceSMap s init sol= sol -- trace (s ++ "\n" ++ showMap sol init) sol + +showMap :: [(Symbol, Stratum)] -> [([Stratum], [Stratum])] -> String +showMap s acc + = "\nMap lenght = " ++ show (length acc) ++ "\n" ++ + "Solved = (" ++ show (length s) ++ ")\n" ++ show s ++ "\n" + ++ concatMap (\xs -> (show xs ++ "\n") ) acc ++ "\n\n" + +allSVars (xs, ys) = all isSVar $ xs ++ ys +noSVar (xs, ys) = all (not . isSVar) (xs ++ ys) +noUpdate (xs, ys) = (not $ updateFin(xs, ys)) && (not $ updateDiv (xs, ys)) + +updateFin (xs, ys) = any (==SFin) ys && any isSVar xs +updateDiv (xs, ys) = any isSVar ys && any (==SDiv) xs + +solve (xs, ys) + | any (== SDiv) xs = [(l, SDiv) | SVar l <- ys] + | any (== SFin) ys = [(l, SFin) | SVar l <- xs] + | otherwise = [] + + +class SubStratum a where + subS :: (Symbol, Stratum) -> a -> a + subsS :: [(Symbol, Stratum)] -> a -> a + + subsS su x = foldr subS x su + +instance SubStratum Stratum where + subS (x, s) (SVar y) | x == y = s + | otherwise = (SVar y) + subS _ s = s + + +instance (SubStratum a, SubStratum b) => SubStratum (a, b) where + subS su (x, y) = (subS su x, subS su y) + +instance (SubStratum a) => SubStratum [a] where + subS su xs = subS su <$> xs + +instance SubStratum (Annot SpecType) where + subS su (AnnUse t) = AnnUse $ subS su t + subS su (AnnDef t) = AnnDef $ subS su t + subS su (AnnRDf t) = AnnRDf $ subS su t + subS su (AnnLoc s) = AnnLoc s + +instance SubStratum SpecType where + subS su t = (\r -> r {ur_strata = subS su (ur_strata r)}) <$> t + + diff --git a/src/Language/Haskell/Liquid/Tidy.hs b/src/Language/Haskell/Liquid/Tidy.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Tidy.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE OverloadedStrings #-} +--------------------------------------------------------------------- +-- | This module contains functions for cleaning up types before +-- they are rendered, e.g. in error messages or annoations. +--------------------------------------------------------------------- + + +module Language.Haskell.Liquid.Tidy ( + + -- * Tidying functions + tidySpecType + , tidySymbol + + -- * Tidyness tests + , isTmpSymbol + ) where + +import Outputable (showPpr) -- hiding (empty) +import Control.Applicative +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import qualified Data.List as L +import qualified Data.Text as T +import Data.Maybe (fromMaybe) + + +import Language.Fixpoint.Misc +import Language.Fixpoint.Names (symSepName, isPrefixOfSym, takeWhileSym) +import Language.Fixpoint.Types +import Language.Haskell.Liquid.GhcMisc (stringTyVar) +import Language.Haskell.Liquid.Types +import Language.Haskell.Liquid.PrettyPrint +import Language.Haskell.Liquid.RefType hiding (shiftVV) + +------------------------------------------------------------------------- +tidySymbol :: Symbol -> Symbol +------------------------------------------------------------------------- +tidySymbol = takeWhileSym (/= symSepName) + + +------------------------------------------------------------------------- +isTmpSymbol :: Symbol -> Bool +------------------------------------------------------------------------- +isTmpSymbol x = any (`isPrefixOfSym` x) [anfPrefix, tempPrefix, "ds_"] + + +------------------------------------------------------------------------- +tidySpecType :: Tidy -> SpecType -> SpecType +------------------------------------------------------------------------- +tidySpecType k = tidyValueVars + . tidyDSymbols + . tidySymbols + . tidyLocalRefas k + . tidyFunBinds + . tidyTyVars + +tidyValueVars :: SpecType -> SpecType +tidyValueVars = mapReft $ \u -> u { ur_reft = tidyVV $ ur_reft u } + +tidyVV r@(Reft (va,_)) + | isJunk va = shiftVV r v' + | otherwise = r + where + v' = if v `elem` xs then symbol ("v'" :: T.Text) else v + v = symbol ("v" :: T.Text) + xs = syms r + isJunk = isPrefixOfSym "x" + +tidySymbols :: SpecType -> SpecType +tidySymbols t = substa tidySymbol $ mapBind dropBind t + where + xs = S.fromList (syms t) + dropBind x = if x `S.member` xs then tidySymbol x else nonSymbol + + +tidyLocalRefas :: Tidy -> SpecType -> SpecType +tidyLocalRefas k = mapReft (txStrata . txReft' k) + where + txReft' Full = id + txReft' Lossy = txReft + txStrata (U r p l) = U r p (txStr l) + txReft (U (Reft (v,ras)) p l) = U (Reft (v, dropLocals ras)) p l + dropLocals = filter (not . any isTmp . syms) . flattenRefas + isTmp x = any (`isPrefixOfSym` x) [anfPrefix, "ds_"] + txStr = filter (not . isSVar) + + + +tidyDSymbols :: SpecType -> SpecType +tidyDSymbols t = mapBind tx $ substa tx t + where + tx = bindersTx [x | x <- syms t, isTmp x] + isTmp = (tempPrefix `isPrefixOfSym`) + +tidyFunBinds :: SpecType -> SpecType +tidyFunBinds t = mapBind tx $ substa tx t + where + tx = bindersTx $ filter isTmpSymbol $ funBinds t + +tidyTyVars :: SpecType -> SpecType +tidyTyVars t = subsTyVarsAll αβs t + where + -- zz = [(a, b) | (a, _, (RVar b _)) <- αβs] + αβs = zipWith (\α β -> (α, toRSort β, β)) αs βs + αs = L.nub (tyVars t) + βs = map (rVar . stringTyVar) pool + pool = [[c] | c <- ['a'..'z']] ++ [ "t" ++ show i | i <- [1..]] + + +bindersTx ds = \y -> M.lookupDefault y y m + where + m = M.fromList $ zip ds $ var <$> [1..] + var = symbol . ('x' :) . show + + +tyVars (RAllP _ t) = tyVars t +tyVars (RAllS _ t) = tyVars t +tyVars (RAllT α t) = α : tyVars t +tyVars (RFun _ t t' _) = tyVars t ++ tyVars t' +tyVars (RAppTy t t' _) = tyVars t ++ tyVars t' +tyVars (RApp _ ts _ _) = concatMap tyVars ts +tyVars (RCls _ ts) = concatMap tyVars ts +tyVars (RVar α _) = [α] +tyVars (RAllE _ _ t) = tyVars t +tyVars (REx _ _ t) = tyVars t +tyVars (RExprArg _) = [] +tyVars (RRTy _ _ _ t) = tyVars t +tyVars (ROth _) = [] + +subsTyVarsAll ats = go + where + abm = M.fromList [(a, b) | (a, _, (RVar b _)) <- ats] + go (RAllT a t) = RAllT (M.lookupDefault a a abm) (go t) + go t = subsTyVars_meet ats t + + +funBinds (RAllT _ t) = funBinds t +funBinds (RAllP _ t) = funBinds t +funBinds (RAllS _ t) = funBinds t +funBinds (RFun b t1 t2 _) = b : funBinds t1 ++ funBinds t2 +funBinds (RApp _ ts _ _) = concatMap funBinds ts +funBinds (RCls _ ts) = concatMap funBinds ts +funBinds (RAllE b t1 t2) = b : funBinds t1 ++ funBinds t2 +funBinds (REx b t1 t2) = b : funBinds t1 ++ funBinds t2 +funBinds (RVar _ _) = [] +funBinds (ROth _) = [] +funBinds (RRTy _ _ _ t) = funBinds t +funBinds (RAppTy t1 t2 r) = funBinds t1 ++ funBinds t2 +funBinds (RExprArg e) = [] + diff --git a/src/Language/Haskell/Liquid/TransformRec.hs b/src/Language/Haskell/Liquid/TransformRec.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/TransformRec.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Language.Haskell.Liquid.TransformRec ( + transformRecExpr, transformScope + ) where + +import Bag +import Coercion +import Control.Arrow (second, (***)) +import Control.Monad.State +import CoreLint +import CoreSyn +import qualified Data.HashMap.Strict as M +import ErrUtils +import Id (idOccInfo, setIdInfo) +import IdInfo +import MkCore (mkCoreLams) +import SrcLoc +import Type (mkForAllTys) +import TypeRep +import Unique hiding (deriveUnique) +import Var +import Language.Haskell.Liquid.GhcMisc +import Language.Haskell.Liquid.Misc (mapSndM) + +import Data.List (foldl', isInfixOf) +import Control.Applicative ((<$>)) + +transformRecExpr :: CoreProgram -> CoreProgram +transformRecExpr cbs + | isEmptyBag $ filterBag isTypeError e + = {-trace "new cbs"-} pg + | otherwise + = error (showPpr pg ++ "Type-check" ++ showSDoc (pprMessageBag e)) + where pg = evalState (transPg cbs) initEnv + (_, e) = lintCoreBindings [] pg + +isTypeError s | isInfixOf "Non term variable" (showSDoc s) = False +isTypeError _ = True + +scopeTr = outerScTr . innerScTr +transformScope = outerScTr . innerScTr + +outerScTr = mapNonRec (go []) + where + go ack x (xe : xes) | isCaseArg x xe = go (xe:ack) x xes + go ack _ xes = ack ++ xes + +isCaseArg x (NonRec _ (Case (Var z) _ _ _)) = z == x +isCaseArg _ _ = False + +innerScTr = (mapBnd scTrans <$>) + +scTrans x e = mapExpr scTrans $ foldr Let e0 bs + where (bs, e0) = go [] x e + go bs x (Let b e) | isCaseArg x b = go (b:bs) x e + go bs x (Tick t e) = second (Tick t) $ go bs x e + go bs x e = (bs, e) + +type TE = State TrEnv + +data TrEnv = Tr { freshIndex :: !Int + , loc :: SrcSpan + } + +initEnv = Tr 0 noSrcSpan + +transPg = mapM transBd + +transBd (NonRec x e) = liftM (NonRec x) (transExpr =<< mapBdM transBd e) +transBd (Rec xes) = liftM Rec $ mapM (mapSndM (mapBdM transBd)) xes + +transExpr :: CoreExpr -> TE CoreExpr +transExpr e + | (isNonPolyRec e') && (not (null tvs)) + = trans tvs ids bs e' + | otherwise + = return e + where (tvs, ids, e'') = collectTyAndValBinders e + (bs, e') = collectNonRecLets e'' + +isNonPolyRec (Let (Rec xes) _) = any nonPoly (snd <$> xes) +isNonPolyRec _ = False + +nonPoly = null . fst . collectTyBinders + +collectNonRecLets = go [] + where go bs (Let b@(NonRec _ _) e') = go (b:bs) e' + go bs e' = (reverse bs, e') + +appTysAndIds tvs ids x = mkApps (mkTyApps (Var x) (map TyVarTy tvs)) (map Var ids) + +trans vs ids bs (Let (Rec xes) e) + = liftM (mkLam . mkLet) (makeTrans vs liveIds e') + where liveIds = mkAlive <$> ids + mkLet e = foldr Let e bs + mkLam e = foldr Lam e $ vs ++ liveIds + e' = Let (Rec xes') e + xes' = (second mkLet) <$> xes + +makeTrans vs ids (Let (Rec xes) e) + = do fids <- mapM (mkFreshIds vs ids) xs + let (ids', ys) = unzip fids + let yes = appTysAndIds vs ids <$> ys + ys' <- mapM fresh xs + let su = M.fromList $ zip xs (Var <$> ys') + let rs = zip ys' yes + let es' = zipWith (mkE ys) ids' es + let xes' = zip ys es' + return $ mkRecBinds rs (Rec xes') (sub su e) + where + (xs, es) = unzip xes + mkSu ys ids' = mkSubs ids vs ids' (zip xs ys) + mkE ys ids' e' = mkCoreLams (vs ++ ids') (sub (mkSu ys ids') e') + +mkRecBinds :: [(b, Expr b)] -> Bind b -> Expr b -> Expr b +mkRecBinds xes rs e = Let rs (foldl' f e xes) + where f e (x, xe) = Let (NonRec x xe) e + +mkSubs ids tvs xs ys = M.fromList $ s1 ++ s2 + where s1 = (second (appTysAndIds tvs xs)) <$> ys + s2 = zip ids (Var <$> xs) + +mkFreshIds tvs ids x + = do ids' <- mapM fresh ids + let t = mkForAllTys tvs $ mkType (reverse ids') $ varType x + let x' = setVarType x t + return (ids', x') + where + mkType ids ty = foldl (\t x -> FunTy (varType x) t) ty ids + +class Freshable a where + fresh :: a -> TE a + +instance Freshable Int where + fresh _ = freshInt + +instance Freshable Unique where + fresh _ = freshUnique + +instance Freshable Var where + fresh v = liftM (setVarUnique v) freshUnique + +freshInt + = do s <- get + let n = freshIndex s + put s{freshIndex = n+1} + return n + +freshUnique = liftM (mkUnique 'X') freshInt + +mkAlive x + | isId x && isDeadOcc (idOccInfo x) + = setIdInfo x (setOccInfo (idInfo x) NoOccInfo) + | otherwise + = x + +class Subable a where + sub :: M.HashMap CoreBndr CoreExpr -> a -> a + subTy :: M.HashMap TyVar Type -> a -> a + +instance Subable CoreExpr where + sub s (Var v) = M.lookupDefault (Var v) v s + sub _ (Lit l) = Lit l + sub s (App e1 e2) = App (sub s e1) (sub s e2) + sub s (Lam b e) = Lam b (sub s e) + sub s (Let b e) = Let (sub s b) (sub s e) + sub s (Case e b t a) = Case (sub s e) (sub s b) t (map (sub s) a) + sub s (Cast e c) = Cast (sub s e) c + sub s (Tick t e) = Tick t (sub s e) + sub _ (Type t) = Type t + sub _ (Coercion c) = Coercion c + + subTy s (Var v) = Var (subTy s v) + subTy _ (Lit l) = Lit l + subTy s (App e1 e2) = App (subTy s e1) (subTy s e2) + subTy s (Lam b e) | isTyVar b = Lam v' (subTy s e) + where v' = case M.lookup b s of + Nothing -> b + Just (TyVarTy v) -> v + + subTy s (Lam b e) = Lam (subTy s b) (subTy s e) + subTy s (Let b e) = Let (subTy s b) (subTy s e) + subTy s (Case e b t a) = Case (subTy s e) (subTy s b) (subTy s t) (map (subTy s) a) + subTy s (Cast e c) = Cast (subTy s e) (subTy s c) + subTy s (Tick t e) = Tick t (subTy s e) + subTy s (Type t) = Type (subTy s t) + subTy s (Coercion c) = Coercion (subTy s c) + +instance Subable Coercion where + sub _ c = c + subTy _ _ = error "subTy Coercion" + +instance Subable (Alt Var) where + sub s (a, b, e) = (a, map (sub s) b, sub s e) + subTy s (a, b, e) = (a, map (subTy s) b, subTy s e) + +instance Subable Var where + sub s v | M.member v s = subVar $ s M.! v + | otherwise = v + subTy s v = setVarType v (subTy s (varType v)) + +subVar (Var x) = x +subVar _ = error "sub Var" + +instance Subable (Bind Var) where + sub s (NonRec x e) = NonRec (sub s x) (sub s e) + sub s (Rec xes) = Rec ((sub s *** sub s) <$> xes) + + subTy s (NonRec x e) = NonRec (subTy s x) (subTy s e) + subTy s (Rec xes) = Rec ((subTy s *** subTy s) <$> xes) + +instance Subable Type where + sub _ e = e + subTy = substTysWith + +substTysWith s tv@(TyVarTy v) = M.lookupDefault tv v s +substTysWith s (FunTy t1 t2) = FunTy (substTysWith s t1) (substTysWith s t2) +substTysWith s (ForAllTy v t) = ForAllTy v (substTysWith (M.delete v s) t) +substTysWith s (TyConApp c ts) = TyConApp c (map (substTysWith s) ts) +substTysWith s (AppTy t1 t2) = AppTy (substTysWith s t1) (substTysWith s t2) + +mapNonRec f (NonRec x xe:xes) = NonRec x xe : f x (mapNonRec f xes) +mapNonRec f (xe:xes) = xe : mapNonRec f xes +mapNonRec _ [] = [] + +mapBnd f (NonRec b e) = NonRec b (mapExpr f e) +mapBnd f (Rec bs) = Rec (map (second (mapExpr f)) bs) + +mapExpr f (Let (NonRec x ex) e) = Let (NonRec x (f x ex) ) (f x e) +mapExpr f (App e1 e2) = App (mapExpr f e1) (mapExpr f e2) +mapExpr f (Lam b e) = Lam b (mapExpr f e) +mapExpr f (Let bs e) = Let (mapBnd f bs) (mapExpr f e) +mapExpr f (Case e b t alt) = Case e b t (map (mapAlt f) alt) +mapExpr f (Tick t e) = Tick t (mapExpr f e) +mapExpr _ e = e + +mapAlt f (d, bs, e) = (d, bs, mapExpr f e) + +-- Do not apply transformations to inner code + +mapBdM _ = return + +-- mapBdM f (Let b e) = liftM2 Let (f b) (mapBdM f e) +-- mapBdM f (App e1 e2) = liftM2 App (mapBdM f e1) (mapBdM f e2) +-- mapBdM f (Lam b e) = liftM (Lam b) (mapBdM f e) +-- mapBdM f (Case e b t alt) = liftM (Case e b t) (mapM (mapBdAltM f) alt) +-- mapBdM f (Tick t e) = liftM (Tick t) (mapBdM f e) +-- mapBdM _ e = return e +-- +-- mapBdAltM f (d, bs, e) = liftM ((,,) d bs) (mapBdM f e) diff --git a/src/Language/Haskell/Liquid/Types.hs b/src/Language/Haskell/Liquid/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/Types.hs @@ -0,0 +1,1702 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module should contain all the global type definitions and basic instances. + +module Language.Haskell.Liquid.Types ( + + -- * Options + Config (..), canonicalizePaths + + -- * Ghc Information + , GhcInfo (..) + , GhcSpec (..) + , TargetVars (..) + + -- * Located Things + , Located (..) + , dummyLoc + + -- * Symbols + , LocSymbol + , LocText + + -- * Default unknown name + , dummyName, isDummy + + -- * Refined Type Constructors + , RTyCon (RTyCon, rtc_tc, rtc_info) + , TyConInfo(..) + , rTyConPVs + , rTyConPropVs + + -- * Refinement Types + , RType (..), Ref(..), RTProp (..) + , RTyVar (..) + , RTAlias (..) + + -- * Worlds + , HSeg (..) + , World (..) + + -- * Classes describing operations on `RTypes` + , TyConable (..) + , RefTypable (..) + , SubsTy (..) + + -- * Predicate Variables + , PVar (PV, pname, parg, ptype, pargs), isPropPV, pvType + , PVKind (..) + , Predicate (..) + + -- * Refinements + , UReft(..) + + -- * Parse-time entities describing refined data types + , DataDecl (..) + , DataConP (..) + , TyConP (..) + + -- * Pre-instantiated RType + , RRType, BRType, RRProp + , BSort, BPVar + + -- * Instantiated RType + , BareType, RefType, PrType + , SpecType, SpecProp + , RSort + , UsedPVar, RPVar, RReft + , REnv (..) + + -- * Constructing & Destructing RTypes + , RTypeRep(..), fromRTypeRep, toRTypeRep + , mkArrow, bkArrowDeep, bkArrow, safeBkArrow + , mkUnivs, bkUniv, bkClass + , rFun + + -- * Manipulating `Predicates` + , pvars, pappSym, pToRef, pApp + + -- * Some tests on RTypes + , isBase + , isFunTy + , isTrivial + + -- * Traversing `RType` + , efoldReft, foldReft + , mapReft, mapReftM + , mapBot, mapBind + + -- * ??? + , Oblig(..) + , ignoreOblig + , addTermCond + , addInvCond + + + -- * Inferred Annotations + , AnnInfo (..) + , Annot (..) + + -- * Overall Output + , Output (..) + + -- * Refinement Hole + , hole, isHole, hasHole + + -- * Converting To and From Sort + , ofRSort, toRSort + , rTypeValueVar + , rTypeReft + , stripRTypeBase + + -- * Class for values that can be pretty printed + , PPrint (..) + , showpp + + -- * Printer Configuration + , PPEnv (..) + , Tidy (..) + , ppEnv + , ppEnvShort + + -- * Modules and Imports + , ModName (..), ModType (..) + , isSrcImport, isSpecImport + , getModName, getModString + + -- * Refinement Type Aliases + , RTEnv (..) + , RTBareOrSpec + , mapRT + , mapRP + + -- * Final Result + , Result (..) + + -- * Errors and Error Messages + , Error + , TError (..) + , EMsg (..) + , LParseError (..) + , ErrorResult + , errSpan + , errOther + + -- * Source information (associated with constraints) + , Cinfo (..) + + -- * Measures + , Measure (..) + , CMeasure (..) + , Def (..) + , Body (..) + + -- * Type Classes + , RClass (..) + + -- * KV Profiling + , KVKind (..) -- types of kvars + , KVProf -- profile table + , emptyKVProf -- empty profile + , updKVProf -- extend profile + + -- * Misc + , classToRApp + , mapRTAVars + , insertsSEnv + + -- * Strata + , Stratum(..), Strata + , isSVar + , getStrata + , makeDivType, makeFinType + + ) + where + +import FastString (fsLit) +import SrcLoc (noSrcSpan, mkGeneralSrcSpan, SrcSpan) +import TyCon +import DataCon +import Name (getName) +import NameSet +import Module (moduleNameFS) +import Class (classTyCon) +import TypeRep hiding (maybeParen, pprArrowChain) +import Var +import Unique +import Literal +import Text.Printf +import GHC (Class, HscEnv, ModuleName, Name, moduleNameString) +import GHC.Generics +import Language.Haskell.Liquid.GhcMisc + +import Control.Arrow (second) +import Control.Monad (liftM, liftM2, liftM3) +import qualified Control.Monad.Error as Ex +import Control.DeepSeq +import Control.Applicative ((<$>), (<*>)) +import Data.Typeable (Typeable) +import Data.Generics (Data) +import Data.Monoid hiding ((<>)) +import qualified Data.Foldable as F +import Data.Hashable +import qualified Data.HashMap.Strict as M +import qualified Data.HashSet as S +import Data.Function (on) +import Data.Maybe (maybeToList, fromMaybe) +import Data.Traversable hiding (mapM) +import Data.List (isSuffixOf, nub, union, unionBy) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Aeson hiding (Result) +import Text.Parsec.Pos (SourcePos, newPos, sourceName, sourceLine, sourceColumn) +import Text.Parsec.Error (ParseError) +import Text.PrettyPrint.HughesPJ +import Language.Fixpoint.Config hiding (Config) +import Language.Fixpoint.Misc +import Language.Fixpoint.Types hiding (Predicate, Def, R) +-- import qualified Language.Fixpoint.Types as F +import Language.Fixpoint.Names (symSepName, isSuffixOfSym, singletonSym) +import CoreSyn (CoreBind) + +import System.Directory (canonicalizePath) +import System.FilePath ((), isAbsolute, takeDirectory) +import System.Posix.Files (getFileStatus, isDirectory) + +import Data.Default +----------------------------------------------------------------------------- +-- | Command Line Config Options -------------------------------------------- +----------------------------------------------------------------------------- + +-- NOTE: adding strictness annotations breaks the help message +data Config = Config { + files :: [FilePath] -- ^ source files to check + , idirs :: [FilePath] -- ^ path to directory for including specs + , diffcheck :: Bool -- ^ check subset of binders modified (+ dependencies) since last check + , real :: Bool -- ^ supports real number arithmetic + , fullcheck :: Bool -- ^ check all binders (overrides diffcheck) + , binders :: [String] -- ^ set of binders to check + , noCheckUnknown :: Bool -- ^ whether to complain about specifications for unexported and unused values + , notermination :: Bool -- ^ disable termination check + , nocaseexpand :: Bool -- ^ disable case expand + , strata :: Bool -- ^ enable strata analysis + , notruetypes :: Bool -- ^ disable truing top level types + , totality :: Bool -- ^ check totality in definitions + , noPrune :: Bool -- ^ disable prunning unsorted Refinements + , maxParams :: Int -- ^ the maximum number of parameters to accept when mining qualifiers + , smtsolver :: SMTSolver -- ^ name of smtsolver to use [default: z3-API] + , shortNames :: Bool -- ^ drop module qualifers from pretty-printed names. + , shortErrors :: Bool -- ^ don't show subtyping errors and contexts. + , 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) + +-- | 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 + let canonicalize f + | isAbsolute f = return 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 } + + +----------------------------------------------------------------------------- +-- | Printer ---------------------------------------------------------------- +----------------------------------------------------------------------------- + +data Tidy = Lossy | Full deriving (Eq, Ord) + +class PPrint a where + pprint :: a -> Doc + + pprintTidy :: Tidy -> a -> Doc + pprintTidy _ = pprint + +showpp :: (PPrint a) => a -> String +showpp = render . pprint + +showEMsg :: (PPrint a) => a -> EMsg +showEMsg = EMsg . showpp + +instance PPrint a => PPrint (Maybe a) where + pprint = maybe (text "Nothing") ((text "Just" <+>) . pprint) + +instance PPrint a => PPrint [a] where + pprint = brackets . intersperse comma . map pprint + +instance (PPrint a, PPrint b) => PPrint (a,b) where + pprint (x, y) = pprint x <+> text ":" <+> pprint y + +data PPEnv + = PP { ppPs :: Bool + , ppTyVar :: Bool -- TODO if set to True all Bare fails + , ppSs :: Bool + , ppShort :: Bool + } + +ppEnv = ppEnvPrintPreds +ppEnvCurrent = PP False False False False +ppEnvPrintPreds = PP True False False False +ppEnvShort pp = pp { ppShort = True } + + + +------------------------------------------------------------------ +-- | GHC Information : Code & Spec ------------------------------ +------------------------------------------------------------------ + +data GhcInfo = GI { + env :: !HscEnv + , cbs :: ![CoreBind] + , derVars :: ![Var] + , impVars :: ![Var] + , defVars :: ![Var] + , useVars :: ![Var] + , hqFiles :: ![FilePath] + , imports :: ![String] + , includes :: ![FilePath] + , spec :: !GhcSpec + } + +-- | The following is the overall type for /specifications/ obtained from +-- parsing the target source and dependent libraries + +data GhcSpec = SP { + tySigs :: ![(Var, Located SpecType)] -- ^ Asserted Reftypes + -- eg. see include/Prelude.spec + , asmSigs :: ![(Var, Located SpecType)] -- ^ Assumed Reftypes + , ctors :: ![(Var, Located SpecType)] -- ^ Data Constructor Measure Sigs + -- eg. (:) :: a -> xs:[a] -> {v: Int | v = 1 + len(xs) } + , meas :: ![(Symbol, Located RefType)] -- ^ Measure Types + -- eg. len :: [a] -> Int + , invariants :: ![Located SpecType] -- ^ Data Type Invariants + + , ialiases :: ![(Located SpecType, Located SpecType)] -- ^ Data Type Invariant Aliases + -- eg. forall a. {v: [a] | len(v) >= 0} + , dconsP :: ![(DataCon, DataConP)] -- ^ Predicated Data-Constructors + -- e.g. see tests/pos/Map.hs + , tconsP :: ![(TyCon, TyConP)] -- ^ Predicated Type-Constructors + -- eg. see tests/pos/Map.hs + , freeSyms :: ![(Symbol, Var)] -- ^ List of `Symbol` free in spec and corresponding GHC var + -- eg. (Cons, Cons#7uz) from tests/pos/ex1.hs + , tcEmbeds :: TCEmb TyCon -- ^ How to embed GHC Tycons into fixpoint sorts + -- e.g. "embed Set as Set_set" from include/Data/Set.spec + , qualifiers :: ![Qualifier] -- ^ Qualifiers in Source/Spec files + -- e.g tests/pos/qualTest.hs + , tgtVars :: ![Var] -- ^ Top-level Binders To Verify (empty means ALL binders) + , 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 + , config :: !Config -- ^ Configuration Options + , exports :: !NameSet -- ^ `Name`s exported by the module being verified + , measures :: [Measure SpecType DataCon] + , tyconEnv :: M.HashMap TyCon RTyCon + } + + +data TyConP = TyConP { freeTyVarsTy :: ![RTyVar] + , freePredTy :: ![PVar RSort] + , freeLabelTy :: ![Symbol] + , covPs :: ![Int] -- ^ indexes of covariant predicate arguments + , contravPs :: ![Int] -- ^ indexes of contravariant predicate arguments + , sizeFun :: !(Maybe (Symbol -> Expr)) + } deriving (Data, Typeable) + +data DataConP = DataConP { dc_loc :: !SourcePos + , freeTyVars :: ![RTyVar] + , freePred :: ![PVar RSort] + , freeLabels :: ![Symbol] + , tyConsts :: ![SpecType] + , tyArgs :: ![(Symbol, SpecType)] + , tyRes :: !SpecType + } deriving (Data, Typeable) + + +-- | Which Top-Level Binders Should be Verified +data TargetVars = AllVars | Only ![Var] + + +-------------------------------------------------------------------- +-- | Abstract Predicate Variables ---------------------------------- +-------------------------------------------------------------------- + +data PVar t + = PV { pname :: !Symbol + , ptype :: !(PVKind t) + , parg :: !Symbol + , pargs :: ![(t, Symbol, Expr)] + } + deriving (Generic, Data, Typeable, Show) + +pvType p = case ptype p of + PVProp t -> t + PVHProp -> errorstar "pvType on HProp-PVar" + +data PVKind t + = PVProp t | PVHProp + deriving (Generic, Data, Typeable, F.Foldable, Traversable, Show) + +instance Eq (PVar t) where + pv == pv' = pname pv == pname pv' {- UNIFY: What about: && eqArgs pv pv' -} + +instance Ord (PVar t) where + compare (PV n _ _ _) (PV n' _ _ _) = compare n n' + +instance Functor PVKind where + fmap f (PVProp t) = PVProp (f t) + fmap f (PVHProp) = PVHProp + +instance Functor PVar where + fmap f (PV x t v txys) = PV x (f <$> t) v (mapFst3 f <$> txys) + +instance (NFData a) => NFData (PVKind a) where + rnf (PVProp t) = rnf t + rnf (PVHProp) = () + +instance (NFData a) => NFData (PVar a) where + rnf (PV n t v txys) = rnf n `seq` rnf v `seq` rnf t `seq` rnf txys + +instance Hashable (PVar a) where + hashWithSalt i (PV n _ _ xys) = hashWithSalt i n + +-------------------------------------------------------------------- +------------------ Predicates -------------------------------------- +-------------------------------------------------------------------- + +type UsedPVar = PVar () +newtype Predicate = Pr [UsedPVar] deriving (Generic, Data, Typeable) + +instance NFData Predicate where + rnf _ = () + +instance Monoid Predicate where + mempty = pdTrue + mappend p p' = pdAnd [p, p'] + +instance (Monoid a) => Monoid (UReft a) where + mempty = U mempty mempty mempty + mappend (U x y z) (U x' y' z') = U (mappend x x') (mappend y y') (mappend z z') + + +pdTrue = Pr [] +pdAnd ps = Pr (nub $ concatMap pvars ps) +pvars (Pr pvs) = pvs + +instance Subable UsedPVar where + syms pv = [ y | (_, x, EVar y) <- pargs pv, x /= y ] + subst s pv = pv { pargs = mapThd3 (subst s) <$> pargs pv } + substf f pv = pv { pargs = mapThd3 (substf f) <$> pargs pv } + substa f pv = pv { pargs = mapThd3 (substa f) <$> pargs pv } + + +instance Subable Predicate where + syms (Pr pvs) = concatMap syms pvs + subst s (Pr pvs) = Pr (subst s <$> pvs) + substf f (Pr pvs) = Pr (substf f <$> pvs) + substa f (Pr pvs) = Pr (substa f <$> pvs) + +instance Subable Qualifier where + syms = syms . q_body + subst = mapQualBody . subst + substf = mapQualBody . substf + substa = mapQualBody . substa + +mapQualBody f q = q { q_body = f (q_body q) } + +instance NFData r => NFData (UReft r) where + rnf (U r p s) = rnf r `seq` rnf p `seq` rnf s + +instance NFData Strata where + rnf _ = () + +instance NFData PrType where + rnf _ = () + +instance NFData RTyVar where + rnf _ = () + + +-- MOVE TO TYPES +newtype RTyVar = RTV TyVar deriving (Generic, Data, Typeable) + +instance Symbolic RTyVar where + symbol (RTV tv) = symbol . T.pack . showPpr $ tv + +data RTyCon = RTyCon + { rtc_tc :: !TyCon -- ^ GHC Type Constructor + , rtc_pvars :: ![RPVar] -- ^ Predicate Parameters + , rtc_info :: !TyConInfo -- ^ TyConInfo + } + deriving (Generic, Data, Typeable) + +-- | Accessors for @RTyCon@ + +rTyConInfo = rtc_info +rTyConTc = rtc_tc +rTyConPVs = rtc_pvars +rTyConPropVs = filter isPropPV . rtc_pvars +isPropPV = isProp . ptype + +-- rTyConPVHPs = filter isHPropPV . rtc_pvars +-- isHPropPV = not . isPropPV + +isProp (PVProp _) = True +isProp _ = False + + +defaultTyConInfo = TyConInfo [] [] [] [] Nothing + +instance Default TyConInfo where + def = defaultTyConInfo + + +----------------------------------------------------------------------- +-- | Co- and Contra-variance for TyCon -------------------------------- +----------------------------------------------------------------------- + +-- | Indexes start from 0 and type or predicate arguments can be both +-- covariant and contravaariant e.g., for the below Foo dataType +-- +-- data Foo a b c d

Prop, q :: Int -> Prop, r :: a -> Prop> +-- = F (a -> b

) | Q (c -> a) | G (Int -> a) +-- +-- there will be: +-- +-- covariantTyArgs = [0, 1, 3], for type arguments a, b and d +-- contravariantTyArgs = [0, 2, 3], for type arguments a, c and d +-- covariantPsArgs = [0, 2], for predicate arguments p and r +-- contravariantPsArgs = [1, 2], for predicate arguments q and r +-- +-- does not appear in the data definition, we enforce BOTH +-- con - contra variance + +data TyConInfo = TyConInfo + { covariantTyArgs :: ![Int] -- ^ indexes of covariant type arguments + , contravariantTyArgs :: ![Int] -- ^ indexes of contravariant type arguments + , covariantPsArgs :: ![Int] -- ^ indexes of covariant predicate arguments + , contravariantPsArgs :: ![Int] -- ^ indexes of contravariant predicate arguments + , sizeFunction :: !(Maybe (Symbol -> Expr)) + } deriving (Generic, Data, Typeable) + + +-------------------------------------------------------------------- +---- Unified Representation of Refinement Types -------------------- +-------------------------------------------------------------------- + +-- MOVE TO TYPES +data RType p c tv r + = RVar { + rt_var :: !tv + , rt_reft :: !r + } + + | RFun { + rt_bind :: !Symbol + , rt_in :: !(RType p c tv r) + , rt_out :: !(RType p c tv r) + , rt_reft :: !r + } + + | RAllT { + rt_tvbind :: !tv + , rt_ty :: !(RType p c tv r) + } + + | RAllP { + rt_pvbind :: !(PVar (RType p c tv ())) + , rt_ty :: !(RType p c tv r) + } + + | RAllS { + rt_sbind :: !(Symbol) + , rt_ty :: !(RType p c tv r) + } + + | RApp { + rt_tycon :: !c + , rt_args :: ![RType p c tv r] + , rt_pargs :: ![RTProp p c tv r] + , rt_reft :: !r + } + + | RCls { + rt_class :: !p + , rt_args :: ![RType p c tv r] + } + + | RAllE { + rt_bind :: !Symbol + , rt_allarg :: !(RType p c tv r) + , rt_ty :: !(RType p c tv r) + } + + | REx { + rt_bind :: !Symbol + , rt_exarg :: !(RType p c tv r) + , rt_ty :: !(RType p c tv r) + } + + | RExprArg Expr -- ^ For expression arguments to type aliases + -- see tests/pos/vector2.hs + | RAppTy{ + rt_arg :: !(RType p c tv r) + , rt_res :: !(RType p c tv r) + , rt_reft :: !r + } + + | RRTy { + rt_env :: ![(Symbol, RType p c tv r)] + , rt_ref :: !r + , rt_obl :: !Oblig + , rt_ty :: !(RType p c tv r) + } + | ROth !Symbol + + | RHole r -- ^ let LH match against the Haskell type and add k-vars, e.g. `x:_` + -- see tests/pos/Holes.hs + deriving (Generic, Data, Typeable) + +data Oblig + = OTerm -- ^ Obligation that proves termination + | OInv -- ^ Obligation that proves invariants + deriving (Generic, Data, Typeable) + +ignoreOblig (RRTy _ _ _ t) = t +ignoreOblig t = t + +instance Show Oblig where + show OTerm = "termination-condition" + show OInv = "invariant-obligation" + +instance PPrint Oblig where + pprint = text . show + +-- | @Ref@ describes `Prop τ` and `HProp` arguments applied to type constructors. +-- For example, in [a]<{\h -> v > h}>, we apply (via `RApp`) +-- * the `RProp` denoted by `{\h -> v > h}` to +-- * the `RTyCon` denoted by `[]`. +-- Thus, @Ref@ is used for abstract-predicate (arguments) that are associated +-- with _type constructors_ i.e. whose semantics are _dependent upon_ the data-type. +-- In contrast, the `Predicate` argument in `ur_pred` in the @UReft@ applies +-- directly to any type and has semantics _independent of_ the data-type. + +data Ref τ r t + = RPropP { + rf_args :: [(Symbol, τ)] + , rf_reft :: r + } -- ^ Parse-time `RProp` + + | RProp { + rf_args :: [(Symbol, τ)] + , rf_body :: t + } -- ^ Abstract refinement associated with `RTyCon` + + | RHProp { + rf_args :: [(Symbol, τ)] + , rf_heap :: World t + } -- ^ Abstract heap-refinement associated with `RTyCon` + deriving (Generic, Data, Typeable) + +-- | @RTProp@ is a convenient alias for @Ref@ that will save a bunch of typing. +-- In general, perhaps we need not expose @Ref@ directly at all. +type RTProp p c tv r = Ref (RType p c tv ()) r (RType p c tv r) + + +-- | A @World@ is a Separation Logic predicate that is essentially a sequence of binders +-- that satisfies two invariants (TODO:LIQUID): +-- 1. Each `hs_addr :: Symbol` appears at most once, +-- 2. There is at most one `HVar` in a list. + +newtype World t = World [HSeg t] + deriving (Generic, Data, Typeable) + +data HSeg t = HBind {hs_addr :: !Symbol, hs_val :: t} + | HVar UsedPVar + deriving (Generic, Data, Typeable) + +data UReft r + = U { ur_reft :: !r, ur_pred :: !Predicate, ur_strata :: !Strata } + deriving (Generic, Data, Typeable) + +type BRType = RType LocSymbol LocSymbol Symbol +type RRType = RType Class RTyCon RTyVar + +type BSort = BRType () +type RSort = RRType () + +type BPVar = PVar BSort +type RPVar = PVar RSort + +type RReft = UReft Reft +type PrType = RRType Predicate +type BareType = BRType RReft +type SpecType = RRType RReft +type RefType = RRType Reft +type SpecProp = RRProp RReft +type RRProp r = Ref RSort r (RRType r) + + +data Stratum = SVar Symbol | SDiv | SWhnf | SFin + deriving (Generic, Data, Typeable, Eq) + +type Strata = [Stratum] + +isSVar (SVar _) = True +isSVar _ = False + +instance Monoid Strata where + mempty = [] + mappend s1 s2 = nub $ s1 ++ s2 + +class SubsTy tv ty a where + subt :: (tv, ty) -> a -> a + +class (Eq c) => TyConable c where + isFun :: c -> Bool + isList :: c -> Bool + isTuple :: c -> Bool + ppTycon :: c -> Doc + +class ( TyConable c + , Eq p, Eq c, Eq tv + , Hashable tv + , Reftable r + , PPrint r + ) => RefTypable p c tv r + where + ppCls :: p -> [RType p c tv r] -> Doc + ppRType :: Prec -> RType p c tv r -> Doc + +-------------------------------------------------------------------------- +-- | Values Related to Specifications ------------------------------------ +-------------------------------------------------------------------------- + +-- | Data type refinements +data DataDecl = D { tycName :: LocSymbol + -- ^ Type Constructor Name + , tycTyVars :: [Symbol] + -- ^ Tyvar Parameters + , tycPVars :: [PVar BSort] + -- ^ PVar Parameters + , tycTyLabs :: [Symbol] + -- ^ PLabel Parameters + , tycDCons :: [(LocSymbol, [(Symbol, BareType)])] + -- ^ [DataCon, [(fieldName, fieldType)]] + , tycSrcPos :: !SourcePos + -- ^ Source Position + , tycSFun :: (Maybe (Symbol -> Expr)) + -- ^ Measure that should decrease in recursive calls + } + -- deriving (Show) + +-- | For debugging. +instance Show DataDecl where + show dd = printf "DataDecl: data = %s, tyvars = %s" + (show $ tycName dd) + (show $ tycTyVars dd) + +-- | Refinement Type Aliases + +data RTAlias tv ty + = RTA { rtName :: Symbol + , rtTArgs :: [tv] + , rtVArgs :: [tv] + , rtBody :: ty + , rtPos :: SourcePos + } + +mapRTAVars f rt = rt { rtTArgs = f <$> rtTArgs rt + , rtVArgs = f <$> rtVArgs rt + } + +-- | Datacons + +-- JUNK data BDataCon a +-- JUNK = BDc a -- ^ Raw named data constructor +-- JUNK | BTup Int -- ^ Tuple constructor + arity +-- JUNK deriving (Eq, Ord, Show) +-- JUNK +-- JUNK instance Functor BDataCon where +-- JUNK fmap f (BDc x) = BDc (f x) +-- JUNK fmap f (BTup i) = BTup i +-- JUNK +-- JUNK instance Hashable a => Hashable (BDataCon a) where +-- JUNK hashWithSalt i (BDc x) = hashWithSalt i x +-- JUNK hashWithSalt i (BTup j) = hashWithSalt i j + +------------------------------------------------------------------------ +-- | Constructor and Destructors for RTypes ---------------------------- +------------------------------------------------------------------------ + +data RTypeRep p c tv r + = RTypeRep { ty_vars :: [tv] + , ty_preds :: [PVar (RType p c tv ())] + , ty_labels :: [Symbol] + , ty_binds :: [Symbol] + , ty_args :: [RType p c tv r] + , ty_res :: (RType p c tv r) + } + +fromRTypeRep rep + = mkArrow (ty_vars rep) (ty_preds rep) (ty_labels rep) (zip (ty_binds rep) (ty_args rep)) (ty_res rep) + +toRTypeRep :: RType p c tv r -> RTypeRep p c tv r +toRTypeRep t = RTypeRep αs πs ls xs ts t'' + where + (αs, πs, ls, t') = bkUniv t + (xs, ts, t'') = bkArrow t' + +mkArrow αs πs ls xts = mkUnivs αs πs ls . mkArrs xts + where + mkArrs xts t = foldr (uncurry rFun) t xts + +bkArrowDeep (RAllT _ t) = bkArrowDeep t +bkArrowDeep (RAllP _ t) = bkArrowDeep t +bkArrowDeep (RAllS _ t) = bkArrowDeep t +bkArrowDeep (RFun x t t' _) = let (xs, ts, t'') = bkArrowDeep t' in (x:xs, t:ts, t'') +bkArrowDeep t = ([], [], t) + +bkArrow (RFun x t t' _) = let (xs, ts, t'') = bkArrow t' in (x:xs, t:ts, t'') +bkArrow t = ([], [], t) + +safeBkArrow (RAllT _ _) = errorstar "safeBkArrow on RAllT" +safeBkArrow (RAllP _ _) = errorstar "safeBkArrow on RAllP" +safeBkArrow (RAllS _ t) = safeBkArrow t +safeBkArrow t = bkArrow t + +mkUnivs αs πs ls t = foldr RAllT (foldr RAllP (foldr RAllS t ls) πs) αs + +bkUniv :: RType t t1 a t2 -> ([a], [PVar (RType t t1 a ())], [Symbol], RType t t1 a t2) +bkUniv (RAllT α t) = let (αs, πs, ls, t') = bkUniv t in (α:αs, πs, ls, t') +bkUniv (RAllP π t) = let (αs, πs, ls, t') = bkUniv t in (αs, π:πs, ls, t') +bkUniv (RAllS s t) = let (αs, πs, ss, t') = bkUniv t in (αs, πs, s:ss, t') +bkUniv t = ([], [], [], t) + +bkClass (RFun _ (RCls c t) t' _) = let (cs, t'') = bkClass t' in ((c, t):cs, t'') +bkClass t = ([], t) + +rFun b t t' = RFun b t t' mempty + +addTermCond = addObligation OTerm + +addInvCond :: SpecType -> RReft -> SpecType +addInvCond t r' + | null rv + = t + | otherwise + = fromRTypeRep $ trep {ty_res = RRTy [(x', tbd)] r OInv tbd} + where trep = toRTypeRep t + tbd = ty_res trep + r = r'{ur_reft = Reft (v, rx)} + su = (v, EVar x') + x' = "xInv" + rx = [RConc $ PIff (PBexp $ EVar v) $ subst1 r su | RConc r <- rv] + + Reft(v, rv) = ur_reft r' + +addObligation :: Oblig -> SpecType -> RReft -> SpecType +addObligation o t r = mkArrow αs πs ls xts $ RRTy [] r o t2 + where (αs, πs, ls, t1) = bkUniv t + (xs, ts, t2) = bkArrow t1 + xts = zip xs ts + +-------------------------------------------- + +instance Subable Stratum where + syms (SVar s) = [s] + syms _ = [] + subst su (SVar s) = SVar $ subst su s + subst su s = s + substf f (SVar s) = SVar $ substf f s + substf f s = s + substa f (SVar s) = SVar $ substa f s + substa f s = s + +instance Subable Strata where + syms s = concatMap syms s + subst su = (subst su <$>) + substf f = (substf f <$>) + substa f = (substa f <$>) + +instance Reftable Strata where + isTauto [] = True + isTauto _ = False + + ppTy s = error "ppTy on Strata" + toReft s = mempty + params s = [l | SVar l <- s] + bot s = [] + top s = [] + +instance (PPrint r, Reftable r) => Reftable (UReft r) where + isTauto = isTauto_ureft + -- ppTy (U r p) d = ppTy r (ppTy p d) + ppTy = ppTy_ureft + 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) + +isTauto_ureft u = isTauto (ur_reft u) && isTauto (ur_pred u) && (isTauto $ ur_strata u) + +isTauto_ureft' u = isTauto (ur_reft u) && isTauto (ur_pred u) + +ppTy_ureft u@(U r p s) d + | isTauto_ureft u = d + | isTauto_ureft' u = d <> ppr_str s + | otherwise = ppr_reft r (ppTy p d) s + +ppr_reft r d s = braces (toFix v <+> colon <+> d <> ppr_str s <+> text "|" <+> pprint r') + where + r'@(Reft (v, _)) = toReft r + +ppr_str [] = empty +ppr_str s = text "^" <> pprint s + +instance Subable r => Subable (UReft r) where + syms (U r p s) = syms r ++ syms p + subst s (U r z l) = U (subst s r) (subst s z) (subst s l) + substf f (U r z l) = U (substf f r) (substf f z) (substf f l) + substa f (U r z l) = U (substa f r) (substa f z) (substa f l) + +instance (Reftable r, RefTypable p c tv r) => Subable (RTProp p c tv r) where + syms (RPropP ss r) = (fst <$> ss) ++ syms r + syms (RProp ss r) = (fst <$> ss) ++ syms r + + subst su (RPropP ss r) = RPropP ss (subst su r) + subst su (RProp ss t) = RProp ss (subst su <$> t) + + substf f (RPropP ss r) = RPropP ss (substf f r) + substf f (RProp ss t) = RProp ss (substf f <$> t) + substa f (RPropP ss r) = RPropP ss (substa f r) + substa f (RProp ss t) = RProp ss (substa f <$> t) + +instance (Subable r, RefTypable p c tv r) => Subable (RType p c tv r) where + syms = foldReft (\r acc -> syms r ++ acc) [] + substa f = mapReft (substa f) + substf f = emapReft (substf . substfExcept f) [] + subst su = emapReft (subst . substExcept su) [] + subst1 t su = emapReft (\xs r -> subst1Except xs r su) [] t + + + + +instance Reftable Predicate where + isTauto (Pr ps) = null ps + + bot (Pr _) = errorstar "No BOT instance for Predicate" + -- HACK: Hiding to not render types in WEB DEMO. NEED TO FIX. + ppTy r d | isTauto r = d + | not (ppPs ppEnv) = d + | otherwise = d <> (angleBrackets $ pprint r) + + toReft (Pr ps@(p:_)) = Reft (parg p, pToRef <$> ps) + toReft _ = mempty + params = errorstar "TODO: instance of params for Predicate" + + +pToRef p = RConc $ pApp (pname p) $ (EVar $ parg p) : (thd3 <$> pargs p) + +pApp :: Symbol -> [Expr] -> Pred +pApp p es = PBexp $ EApp (dummyLoc $ pappSym $ length es) (EVar p:es) + +pappSym n = symbol $ "papp" ++ show n + +--------------------------------------------------------------- +--------------------------- Visitors -------------------------- +--------------------------------------------------------------- + +isTrivial t = foldReft (\r b -> isTauto r && b) True t + +instance Functor UReft where + fmap f (U r p s) = U (f r) p s + +instance Functor (RType a b c) where + fmap = mapReft + +-- instance Fold.Foldable (RType a b c) where +-- foldr = foldReft + +mapReft :: (r1 -> r2) -> RType p c tv r1 -> RType p c tv r2 +mapReft f = emapReft (\_ -> f) [] + +emapReft :: ([Symbol] -> r1 -> r2) -> [Symbol] -> RType p c tv r1 -> RType p c tv r2 + +emapReft f γ (RVar α r) = RVar α (f γ r) +emapReft f γ (RAllT α t) = RAllT α (emapReft f γ t) +emapReft f γ (RAllP π t) = RAllP π (emapReft f γ t) +emapReft f γ (RAllS p t) = RAllS p (emapReft f γ t) +emapReft f γ (RFun x t t' r) = RFun x (emapReft f γ t) (emapReft f (x:γ) t') (f γ r) +emapReft f γ (RApp c ts rs r) = RApp c (emapReft f γ <$> ts) (emapRef f γ <$> rs) (f γ r) +emapReft f γ (RCls c ts) = RCls c (emapReft f γ <$> ts) +emapReft f γ (RAllE z t t') = RAllE z (emapReft f γ t) (emapReft f γ t') +emapReft f γ (REx z t t') = REx z (emapReft f γ t) (emapReft f γ t') +emapReft _ _ (RExprArg e) = RExprArg e +emapReft f γ (RAppTy t t' r) = RAppTy (emapReft f γ t) (emapReft f γ t') (f γ r) +emapReft f γ (RRTy e r o t) = RRTy (mapSnd (emapReft f γ) <$> e) (f γ r) o (emapReft f γ t) +emapReft _ _ (ROth s) = ROth s +emapReft f γ (RHole r) = RHole (f γ r) + +emapRef :: ([Symbol] -> t -> s) -> [Symbol] -> RTProp p c tv t -> RTProp p c tv s +emapRef f γ (RPropP s r) = RPropP s $ f γ r +emapRef f γ (RProp s t) = RProp s $ emapReft f γ t + +------------------------------------------------------------------------------------------------------ +-- isBase' x t = traceShow ("isBase: " ++ showpp x) $ isBase t + +-- isBase :: RType a -> Bool +isBase (RAllP _ t) = isBase t +isBase (RVar _ _) = True +isBase (RApp _ ts _ _) = all isBase ts +isBase (RFun _ t1 t2 _) = isBase t1 && isBase t2 +isBase (RAppTy t1 t2 _) = isBase t1 && isBase t2 +isBase (RRTy _ _ _ t) = isBase t +isBase _ = False + +isFunTy (RAllE _ _ t) = isFunTy t +isFunTy (RAllS _ t) = isFunTy t +isFunTy (RAllT _ t) = isFunTy t +isFunTy (RAllP _ t) = isFunTy t +isFunTy (RFun _ t1 t2 _) = True +isFunTy _ = False + + +mapReftM :: (Monad m) => (r1 -> m r2) -> RType p c tv r1 -> m (RType p c tv r2) +mapReftM f (RVar α r) = liftM (RVar α) (f r) +mapReftM f (RAllT α t) = liftM (RAllT α) (mapReftM f t) +mapReftM f (RAllP π t) = liftM (RAllP π) (mapReftM f t) +mapReftM f (RAllS s t) = liftM (RAllS s) (mapReftM f t) +mapReftM f (RFun x t t' r) = liftM3 (RFun x) (mapReftM f t) (mapReftM f t') (f r) +mapReftM f (RApp c ts rs r) = liftM3 (RApp c) (mapM (mapReftM f) ts) (mapM (mapRefM f) rs) (f r) +mapReftM f (RCls c ts) = liftM (RCls c) (mapM (mapReftM f) ts) +mapReftM f (RAllE z t t') = liftM2 (RAllE z) (mapReftM f t) (mapReftM f t') +mapReftM f (REx z t t') = liftM2 (REx z) (mapReftM f t) (mapReftM f t') +mapReftM _ (RExprArg e) = return $ RExprArg e +mapReftM f (RAppTy t t' r) = liftM3 RAppTy (mapReftM f t) (mapReftM f t') (f r) +mapReftM _ (ROth s) = return $ ROth s +mapReftM f (RHole r) = liftM RHole (f r) + +mapRefM :: (Monad m) => (t -> m s) -> (RTProp p c tv t) -> m (RTProp p c tv s) +mapRefM f (RPropP s r) = liftM (RPropP s) (f r) +mapRefM f (RProp s t) = liftM (RProp s) (mapReftM f t) + +-- foldReft :: (r -> a -> a) -> a -> RType p c tv r -> a +foldReft f = efoldReft (\_ _ -> []) (\_ -> ()) (\_ _ -> f) (\_ γ -> γ) emptySEnv + +-- efoldReft :: Reftable r =>(p -> [RType p c tv r] -> [(Symbol, a)])-> (RType p c tv r -> a)-> (SEnv a -> Maybe (RType p c tv r) -> r -> c1 -> c1)-> SEnv a-> c1-> RType p c tv r-> c1 +efoldReft cb g f fp = go + where + -- folding over RType + go γ z me@(RVar _ r) = f γ (Just me) r z + go γ z (RAllT _ t) = go γ z t + go γ z (RAllP p t) = go (fp p γ) z t + go γ z (RAllS s t) = go γ z t + go γ z me@(RFun _ (RCls c ts) t' r) = f γ (Just me) r (go (insertsSEnv γ (cb c ts)) (go' γ z ts) t') + go γ z me@(RFun x t t' r) = f γ (Just me) r (go (insertSEnv x (g t) γ) (go γ z t) t') + go γ z me@(RApp _ ts rs r) = f γ (Just me) r (ho' γ (go' (insertSEnv (rTypeValueVar me) (g me) γ) z ts) rs) + + go γ z (RCls c ts) = go' γ z ts + go γ z (RAllE x t t') = go (insertSEnv x (g t) γ) (go γ z t) t' + go γ z (REx x t t') = go (insertSEnv x (g t) γ) (go γ z t) t' + go _ z (ROth _) = z + go γ z me@(RRTy e r o t) = f γ (Just me) r (go γ z t) + go γ z me@(RAppTy t t' r) = f γ (Just me) r (go γ (go γ z t) t') + go _ z (RExprArg _) = z + go γ z me@(RHole r) = f γ (Just me) r z + + -- folding over Ref + ho γ z (RPropP ss r) = f (insertsSEnv γ (mapSnd (g . ofRSort) <$> ss)) Nothing r z + ho γ z (RProp ss t) = go (insertsSEnv γ ((mapSnd (g . ofRSort)) <$> ss)) z t + + -- folding over [RType] + go' γ z ts = foldr (flip $ go γ) z ts + + -- folding over [Ref] + ho' γ z rs = foldr (flip $ ho γ) z rs + + +mapBot f (RAllT α t) = RAllT α (mapBot f t) +mapBot f (RAllP π t) = RAllP π (mapBot f t) +mapBot f (RAllS s t) = RAllS s (mapBot f t) +mapBot f (RFun x t t' r) = RFun x (mapBot f t) (mapBot f t') r +mapBot f (RAppTy t t' r) = RAppTy (mapBot f t) (mapBot f t') r +mapBot f (RApp c ts rs r) = f $ RApp c (mapBot f <$> ts) (mapBotRef f <$> rs) r +mapBot f (RCls c ts) = RCls c (mapBot f <$> ts) +mapBot f (REx b t1 t2) = REx b (mapBot f t1) (mapBot f t2) +mapBot f (RAllE b t1 t2) = RAllE b (mapBot f t1) (mapBot f t2) +mapBot f t' = f t' +mapBotRef _ (RPropP s r) = RPropP s $ r +mapBotRef f (RProp s t) = RProp s $ mapBot f t + +mapBind f (RAllT α t) = RAllT α (mapBind f t) +mapBind f (RAllP π t) = RAllP π (mapBind f t) +mapBind f (RAllS s t) = RAllS s (mapBind f t) +mapBind f (RFun b t1 t2 r) = RFun (f b) (mapBind f t1) (mapBind f t2) r +mapBind f (RApp c ts rs r) = RApp c (mapBind f <$> ts) (mapBindRef f <$> rs) r +mapBind f (RCls c ts) = RCls c (mapBind f <$> ts) +mapBind f (RAllE b t1 t2) = RAllE (f b) (mapBind f t1) (mapBind f t2) +mapBind f (REx b t1 t2) = REx (f b) (mapBind f t1) (mapBind f t2) +mapBind _ (RVar α r) = RVar α r +mapBind _ (ROth s) = ROth s +mapBind _ (RHole r) = RHole r +mapBind f (RRTy e r o t) = RRTy e r o (mapBind f t) +mapBind _ (RExprArg e) = RExprArg e +mapBind f (RAppTy t t' r) = RAppTy (mapBind f t) (mapBind f t') r + +mapBindRef f (RPropP s r) = RPropP (mapFst f <$> s) r +mapBindRef f (RProp s t) = RProp (mapFst f <$> s) $ mapBind f t + + +-------------------------------------------------- +ofRSort :: Reftable r => RType p c tv () -> RType p c tv r +ofRSort = fmap mempty + +toRSort :: RType p c tv r -> RType p c tv () +toRSort = stripQuantifiers . mapBind (const dummySymbol) . fmap (const ()) + +stripQuantifiers (RAllT α t) = RAllT α (stripQuantifiers t) +stripQuantifiers (RAllP _ t) = stripQuantifiers t +stripQuantifiers (RAllS _ t) = stripQuantifiers t +stripQuantifiers (RAllE _ _ t) = stripQuantifiers t +stripQuantifiers (REx _ _ t) = stripQuantifiers t +stripQuantifiers (RFun x t t' r) = RFun x (stripQuantifiers t) (stripQuantifiers t') r +stripQuantifiers (RAppTy t t' r) = RAppTy (stripQuantifiers t) (stripQuantifiers t') r +stripQuantifiers (RApp c ts rs r) = RApp c (stripQuantifiers <$> ts) (stripQuantifiersRef <$> rs) r +stripQuantifiers (RCls c ts) = RCls c (stripQuantifiers <$> ts) +stripQuantifiers t = t +stripQuantifiersRef (RProp s t) = RProp s $ stripQuantifiers t +stripQuantifiersRef r = r + + +insertsSEnv = foldr (\(x, t) γ -> insertSEnv x t γ) + +rTypeValueVar :: (Reftable r) => RType p c tv r -> Symbol +rTypeValueVar t = vv where Reft (vv,_) = rTypeReft t + +rTypeReft :: (Reftable r) => RType p c tv r -> Reft +rTypeReft = fromMaybe trueReft . fmap toReft . stripRTypeBase + +-- stripRTypeBase :: RType a -> Maybe a +stripRTypeBase (RApp _ _ _ x) + = Just x +stripRTypeBase (RVar _ x) + = Just x +stripRTypeBase (RFun _ _ _ x) + = Just x +stripRTypeBase (RAppTy _ _ x) + = Just x +stripRTypeBase _ + = Nothing + +mapRBase f (RApp c ts rs r) = RApp c ts rs $ f r +mapRBase f (RVar a r) = RVar a $ f r +mapRBase f (RFun x t1 t2 r) = RFun x t1 t2 $ f r +mapRBase f (RAppTy t1 t2 r) = RAppTy t1 t2 $ f r +mapRBase f t = t + + + +makeLType :: Stratum -> SpecType -> SpecType +makeLType l t = fromRTypeRep trep{ty_res = mapRBase f $ ty_res trep} + where trep = toRTypeRep t + f (U r p s) = U r p [l] + + +makeDivType = makeLType SDiv +makeFinType = makeLType SFin + +getStrata = maybe [] ur_strata . stripRTypeBase + +----------------------------------------------------------------------------- +-- | PPrint ----------------------------------------------------------------- +----------------------------------------------------------------------------- + +instance Show Stratum where + show SFin = "Fin" + show SDiv = "Div" + show SWhnf = "Whnf" + show (SVar s) = show s + +instance PPrint Stratum where + pprint = text . show + +instance PPrint Strata where + pprint [] = empty + pprint ss = hsep (pprint <$> nub ss) + +instance PPrint SourcePos where + pprint = text . show + +instance PPrint () where + pprint = text . show + +instance PPrint String where + pprint = text + +instance PPrint Text where + pprint = text . T.unpack + +instance PPrint a => PPrint (Located a) where + pprint = pprint . val + +instance PPrint Int where + pprint = toFix + +instance PPrint Integer where + pprint = toFix + +instance PPrint Constant where + pprint = toFix + +instance PPrint Brel where + pprint Eq = text "==" + pprint Ne = text "/=" + pprint r = toFix r + +instance PPrint Bop where + pprint = toFix + +instance PPrint Sort where + pprint = toFix + +instance PPrint Symbol where + pprint = pprint . symbolText + +instance PPrint Expr where + pprint (EApp f es) = {- parens $ -} intersperse empty $ (pprint f) : (pprint <$> es) + pprint (ECon c) = pprint c + pprint (EVar s) = pprint s + pprint (ELit s _) = pprint s + pprint (EBin o e1 e2) = {- parens $ -} pprint e1 <+> pprint o <+> pprint e2 + pprint (EIte p e1 e2) = {- parens $ -} text "if" <+> parens (pprint p) <+> text "then" <+> pprint e1 <+> text "else" <+> pprint e2 + pprint (ECst e so) = parens $ pprint e <+> text " : " <+> pprint so + pprint (EBot) = text "_|_" + pprint (ESym s) = pprint s + +instance PPrint SymConst where + pprint (SL s) = text $ T.unpack s + +instance PPrint Pred where + pprint PTop = text "???" + pprint PTrue = trueD + pprint PFalse = falseD + pprint (PBexp e) = {- parens $ -} pprint e + pprint (PNot p) = {- parens $ -} text "not" <+> parens (pprint p) + pprint (PImp p1 p2) = {- parens $ -} pprint p1 <+> text "=>" <+> pprint p2 + pprint (PIff p1 p2) = {- parens $ -} (pprint p1) <+> text "<=>" <+> (pprint p2) + pprint (PAnd ps) = {- parens $ -} pprintBin trueD andD ps + pprint (POr ps) = {- parens $ -} pprintBin falseD orD ps + pprint (PAtom r e1 e2) = {- parens $ -} pprint e1 <+> pprint r <+> pprint e2 + pprint (PAll xts p) = text "forall" <+> toFix xts <+> text "." <+> pprint p + +trueD = text "true" +falseD = text "false" +andD = text " &&" +orD = text " ||" + +pprintBin b _ [] = b +pprintBin _ o xs = intersperse o $ pprint <$> xs + +-- pprintBin b o [] = b +-- pprintBin b o [x] = pprint x +-- pprintBin b o (x:xs) = pprint x <+> o <+> pprintBin b o xs + +instance PPrint a => PPrint (PVar a) where + pprint (PV s _ _ xts) = pprint s <+> hsep (pprint <$> dargs xts) + where + dargs = map thd3 . takeWhile (\(_, x, y) -> EVar x /= y) + +instance PPrint Predicate where + pprint (Pr []) = text "True" + pprint (Pr pvs) = hsep $ punctuate (text "&") (map pprint pvs) + +instance PPrint Refa where + pprint (RConc p) = pprint p + pprint k = toFix k + +instance PPrint Reft where + pprint r@(Reft (_,ras)) + | isTauto r = text "true" + | otherwise = {- intersperse comma -} pprintBin trueD andD $ flattenRefas ras + +instance PPrint SortedReft where + pprint (RR so (Reft (v, ras))) + = braces + $ (pprint v) <+> (text ":") <+> (toFix so) <+> (text "|") <+> pprint ras + +------------------------------------------------------------------------ +-- | Error Data Type --------------------------------------------------- +------------------------------------------------------------------------ +-- | The type used during constraint generation, used also to define contexts +-- for errors, hence in this file, and NOT in Constraint.hs +newtype REnv = REnv (M.HashMap Symbol SpecType) + +type ErrorResult = FixResult Error + +newtype EMsg = EMsg String deriving (Generic, Data, Typeable) + +instance PPrint EMsg where + pprint (EMsg s) = text s + +-- | In the below, we use EMsg instead of, say, SpecType because +-- the latter is impossible to serialize, as it contains GHC +-- internals like TyCon and Class inside it. + +type Error = TError SpecType + + +-- | INVARIANT : all Error constructors should have a pos field +data TError t = + ErrSubType { pos :: !SrcSpan + , msg :: !Doc + , ctx :: !(M.HashMap Symbol t) + , tact :: !t + , texp :: !t + } -- ^ liquid type error + + | ErrAssType { pos :: !SrcSpan + , obl :: !Oblig + , msg :: !Doc + , ref :: !RReft + } -- ^ liquid type error + + | ErrParse { pos :: !SrcSpan + , msg :: !Doc + , err :: !LParseError + } -- ^ specification parse error + + | ErrTySpec { pos :: !SrcSpan + , var :: !Doc + , typ :: !t + , msg :: !Doc + } -- ^ sort error in specification + + | ErrDupAlias { pos :: !SrcSpan + , var :: !Doc + , kind :: !Doc + , locs :: ![SrcSpan] + } -- ^ multiple alias with same name error + + | ErrDupSpecs { pos :: !SrcSpan + , var :: !Doc + , locs:: ![SrcSpan] + } -- ^ multiple specs for same binder error + + | ErrInvt { pos :: !SrcSpan + , inv :: !t + , msg :: !Doc + } -- ^ Invariant sort error + + | ErrIAl { pos :: !SrcSpan + , inv :: !t + , msg :: !Doc + } -- ^ Using sort error + + | ErrIAlMis { pos :: !SrcSpan + , t1 :: !t + , t2 :: !t + , msg :: !Doc + } -- ^ Incompatible using error + + | ErrMeas { pos :: !SrcSpan + , ms :: !Symbol + , msg :: !Doc + } -- ^ Measure sort error + + | ErrUnbound { pos :: !SrcSpan + , var :: !Doc + } -- ^ Unbound symbol in specification + + | ErrGhc { pos :: !SrcSpan + , msg :: !Doc + } -- ^ GHC error: parsing or type checking + + | ErrMismatch { pos :: !SrcSpan + , var :: !Doc + , hs :: !Type + , texp :: !t + } -- ^ Mismatch between Liquid and Haskell types + + | ErrSaved { pos :: !SrcSpan + , msg :: !Doc + } -- ^ Unexpected PANIC + + | ErrOther { pos :: !SrcSpan + , msg :: !Doc + } -- ^ Unexpected PANIC + deriving (Typeable, Functor) + +data LParseError = LPE !SourcePos [String] + deriving (Data, Typeable, Generic) + + +instance Eq Error where + e1 == e2 = pos e1 == pos e2 + +instance Ord Error where + e1 <= e2 = pos e1 <= pos e2 + +instance Ex.Error Error where + strMsg = errOther . pprint + +errSpan :: TError a -> SrcSpan +errSpan = pos + +errOther :: Doc -> Error +errOther = ErrOther noSrcSpan + +------------------------------------------------------------------------ +-- | Source Information Associated With Constraints -------------------- +------------------------------------------------------------------------ + +data Cinfo = Ci { ci_loc :: !SrcSpan + , ci_err :: !(Maybe Error) + } + deriving (Eq, Ord) + +instance NFData Cinfo + + +------------------------------------------------------------------------ +-- | Converting Results To Answers ------------------------------------- +------------------------------------------------------------------------ + +class Result a where + result :: a -> FixResult Error + +instance Result [Error] where + result es = Crash es "" + +instance Result Error where + result (ErrOther _ d) = UnknownError $ render d + result e = result [e] + +instance Result (FixResult Cinfo) where + result = fmap cinfoError + +-------------------------------------------------------------------------------- +--- Module Names +-------------------------------------------------------------------------------- + +data ModName = ModName !ModType !ModuleName deriving (Eq,Ord) + +instance Show ModName where + show = getModString + +instance Symbolic ModName where + symbol (ModName t m) = symbol m + +instance Symbolic ModuleName where + symbol = symbol . moduleNameFS + +data ModType = Target | SrcImport | SpecImport deriving (Eq,Ord) + +isSrcImport (ModName SrcImport _) = True +isSrcImport _ = False + +isSpecImport (ModName SpecImport _) = True +isSpecImport _ = False + +getModName (ModName _ m) = m + +getModString = moduleNameString . getModName + + +------------------------------------------------------------------------------- +----------- Refinement Type Aliases ------------------------------------------- +------------------------------------------------------------------------------- + +type RTBareOrSpec = Either (ModName, (RTAlias Symbol BareType)) + (RTAlias RTyVar SpecType) + +type RTPredAlias = Either (ModName, RTAlias Symbol Pred) + (RTAlias Symbol Pred) + +data RTEnv = RTE { typeAliases :: M.HashMap Symbol RTBareOrSpec + , predAliases :: M.HashMap Symbol RTPredAlias + } + +instance Monoid RTEnv where + (RTE ta1 pa1) `mappend` (RTE ta2 pa2) = RTE (ta1 `M.union` ta2) (pa1 `M.union` pa2) + mempty = RTE M.empty M.empty + +mapRT f e = e { typeAliases = f $ typeAliases e } +mapRP f e = e { predAliases = f $ predAliases e } + +cinfoError (Ci _ (Just e)) = e +cinfoError (Ci l _) = errOther $ text $ "Cinfo:" ++ showPpr l + + +-------------------------------------------------------------------------------- +--- Measures +-------------------------------------------------------------------------------- +-- MOVE TO TYPES +data Measure ty ctor = M { + name :: LocSymbol + , sort :: ty + , eqns :: [Def ctor] + } deriving (Data, Typeable) + +data CMeasure ty + = CM { cName :: LocSymbol + , cSort :: ty + } + +-- MOVE TO TYPES +data Def ctor + = Def { + measure :: LocSymbol + , ctor :: ctor + , binds :: [Symbol] + , body :: Body + } deriving (Show, Data, Typeable) +deriving instance (Eq ctor) => Eq (Def ctor) + +-- MOVE TO TYPES +data Body + = E Expr -- ^ Measure Refinement: {v | v = e } + | P Pred -- ^ Measure Refinement: {v | (? v) <=> p } + | R Symbol Pred -- ^ Measure Refinement: {v | p} + deriving (Show, Eq, Data, Typeable) + +instance Subable (Measure ty ctor) where + syms (M _ _ es) = concatMap syms es + substa f (M n s es) = M n s $ substa f <$> es + substf f (M n s es) = M n s $ substf f <$> es + subst su (M n s es) = M n s $ subst su <$> es + +instance Subable (Def ctor) where + syms (Def _ _ _ bd) = syms bd + substa f (Def m c b bd) = Def m c b $ substa f bd + substf f (Def m c b bd) = Def m c b $ substf f bd + subst su (Def m c b bd) = Def m c b $ subst su bd + +instance Subable Body where + syms (E e) = syms e + syms (P e) = syms e + syms (R s e) = s:syms e + + substa f (E e) = E $ substa f e + substa f (P e) = P $ substa f e + substa f (R s e) = R s $ substa f e + + substf f (E e) = E $ substf f e + substf f (P e) = P $ substf f e + substf f (R s e) = R s $ substf f e + + subst su (E e) = E $ subst su e + subst su (P e) = P $ subst su e + subst su (R s e) = R s $ subst su e + + +data RClass ty + = RClass { rcName :: LocSymbol + , rcSupers :: [ty] + , rcTyVars :: [Symbol] + , rcMethods :: [(LocSymbol,ty)] + } deriving (Show) + +instance Functor RClass where + fmap f (RClass n ss tvs ms) = RClass n (fmap f ss) tvs (fmap (second f) ms) + + +------------------------------------------------------------------------ +-- | Annotations ------------------------------------------------------- +------------------------------------------------------------------------ + +newtype AnnInfo a = AI (M.HashMap SrcSpan [(Maybe Text, a)]) deriving (Generic) + +data Annot t = AnnUse t + | AnnDef t + | AnnRDf t + | AnnLoc SrcSpan + +instance Monoid (AnnInfo a) where + mempty = AI M.empty + mappend (AI m1) (AI m2) = AI $ M.unionWith (++) m1 m2 + +instance Functor AnnInfo where + fmap f (AI m) = AI (fmap (fmap (\(x, y) -> (x, f y)) ) m) + + +instance NFData a => NFData (AnnInfo a) where + rnf (AI x) = () + +instance NFData (Annot a) where + rnf (AnnDef x) = () + rnf (AnnRDf x) = () + rnf (AnnUse x) = () + rnf (AnnLoc x) = () + +------------------------------------------------------------------------ +-- | Output ------------------------------------------------------------ +------------------------------------------------------------------------ + +data Output a = O { o_vars :: Maybe [String] + , o_warns :: [String] + , o_types :: !(AnnInfo a) + , o_templs :: !(AnnInfo a) + , o_bots :: ![SrcSpan] + , o_result :: FixResult Error + } deriving (Generic) + +emptyOutput = O Nothing [] mempty mempty [] mempty + +instance Monoid (Output a) where + mempty = emptyOutput + mappend o1 o2 = O { o_vars = sortNub <$> mappend (o_vars o1) (o_vars o2) + , o_warns = sortNub $ mappend (o_warns o1) (o_warns o2) + , o_types = mappend (o_types o1) (o_types o2) + , o_templs = mappend (o_templs o1) (o_templs o2) + , o_bots = sortNub $ mappend (o_bots o1) (o_bots o2) + , o_result = mappend (o_result o1) (o_result o2) + } + +----------------------------------------------------------- +-- | KVar Profile ----------------------------------------- +----------------------------------------------------------- + +data KVKind + = RecBindE + | NonRecBindE + | TypeInstE + | PredInstE + | LamE + | CaseE + | LetE + deriving (Generic, Eq, Ord, Show, Enum, Data, Typeable) + +instance Hashable KVKind where + hashWithSalt i = hashWithSalt i. fromEnum + +newtype KVProf = KVP (M.HashMap KVKind Int) + +emptyKVProf :: KVProf +emptyKVProf = KVP M.empty + +updKVProf :: KVKind -> [Symbol] -> KVProf -> KVProf +updKVProf k kvs (KVP m) = KVP $ M.insert k (kn + length kvs) m + where + kn = M.lookupDefault 0 k m + +instance NFData KVKind where + rnf z = z `seq` () + +instance PPrint KVKind where + pprint = text . show + +instance PPrint KVProf where + pprint (KVP m) = pprint $ M.toList m + +instance NFData KVProf where + rnf (KVP m) = rnf m `seq` () + +hole = RKvar "HOLE" mempty + +isHole (RKvar ("HOLE") _) = True +isHole _ = False + +hasHole (toReft -> (Reft (_, rs))) = any isHole rs + +classToRApp :: SpecType -> SpecType +classToRApp (RCls cl ts) + = RApp (RTyCon (classTyCon cl) def def) ts mempty mempty + +instance Symbolic DataCon where + symbol = symbol . dataConWorkId + +instance Symbolic Var where + symbol = varSymbol + +varSymbol :: Var -> Symbol +varSymbol v + | us `isSuffixOfSym` vs = vs + | otherwise = vs `mappend` singletonSym symSepName `mappend` us + where us = symbol $ showPpr $ getDataConVarUnique v + vs = symbol $ getName v + +instance PPrint DataCon where + pprint = text . showPpr + +instance Show DataCon where + show = showpp diff --git a/src/Language/Haskell/Liquid/World.hs b/src/Language/Haskell/Liquid/World.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Liquid/World.hs @@ -0,0 +1,23 @@ +-- | This module contains various functions for operating on the @World@ type defined in +-- Language.Haskell.Liquid.Types + +module Language.Haskell.Liquid.World ( + -- * Empty world + empty + ) where + +import Data.Monoid +import Language.Haskell.Liquid.Types +import Language.Fixpoint.Misc + +empty :: World t +empty = World [] + +sepConj :: World t -> World t -> World t +sepConj = errorstar "TODO:EFFECTS" + +instance Monoid (World t) where + mempty = empty + mappend w1 w2 = sepConj w1 w2 + + diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -0,0 +1,175 @@ +module Main where + +import Control.Applicative +import Control.Monad +import Data.Proxy +import System.Directory +import System.Exit +import System.FilePath +import System.IO +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 + +-- main +-- = do pos <- dirTests "tests/pos" [] ExitSuccess +-- neg <- dirTests "tests/neg" [] (ExitFailure 1) +-- crash <- dirTests "tests/crash" [] (ExitFailure 2) +-- -- benchmarks +-- text <- dirTests "benchmarks/text-0.11.2.3" textIgnored ExitSuccess +-- bs <- dirTests "benchmarks/bytestring-0.9.2.1" [] ExitSuccess +-- esop <- dirTests "benchmarks/esop2013-submission" ["Base0.hs"] ExitSuccess +-- vector_algs <- dirTests "benchmarks/vector-algorithms-0.5.4.2" [] ExitSuccess +-- hscolour <- dirTests "benchmarks/hscolour-1.20.0.0" [] ExitSuccess +-- -- TestTrees +-- let unit = testGroup "Unit" +-- [ testGroup "pos" pos +-- , testGroup "neg" neg +-- , testGroup "crash" crash +-- ] +-- let bench = testGroup "Benchmarks" +-- [ testGroup "text" text +-- , testGroup "bytestring" bs +-- , testGroup "esop" esop +-- , testGroup "vector-algorithms" vector_algs +-- , testGroup "hscolour" hscolour +-- ] +-- defaultMainWithIngredients +-- [ rerunningTests [ listingTests, consoleTestReporter ] +-- , includingOptions [ Option (Proxy :: Proxy NumThreads) ] +-- ] $ testGroup "Tests" [ unit, bench ] + +main :: IO () +main = run =<< tests + where + run = defaultMainWithIngredients [ + rerunningTests [ listingTests, consoleTestReporter ] + , includingOptions [ Option (Proxy :: Proxy NumThreads) ] + ] + + tests = group "Tests" [ unitTests, benchTests ] + +unitTests + = group "Unit" [ + testGroup "pos" <$> dirTests "tests/pos" [] ExitSuccess + , testGroup "neg" <$> dirTests "tests/neg" [] (ExitFailure 1) + , testGroup "crash" <$> dirTests "tests/crash" [] (ExitFailure 2) + ] + +benchTests + = group "Benchmarks" [ + testGroup "text" <$> dirTests "benchmarks/text-0.11.2.3" textIgnored ExitSuccess + , testGroup "bytestring" <$> dirTests "benchmarks/bytestring-0.9.2.1" [] ExitSuccess + , testGroup "esop" <$> dirTests "benchmarks/esop2013-submission" ["Base0.hs"] ExitSuccess + , testGroup "vect-algs" <$> dirTests "benchmarks/vector-algorithms-0.5.4.2" [] ExitSuccess + , testGroup "hscolour" <$> dirTests "benchmarks/hscolour-1.20.0.0" [] ExitSuccess + + ] + +--------------------------------------------------------------------------- +dirTests :: FilePath -> [FilePath] -> ExitCode -> IO [TestTree] +--------------------------------------------------------------------------- +dirTests root ignored code + = do files <- walkDirectory root + let tests = [ rel | f <- files, isTest f, let rel = makeRelative root f, rel `notElem` ignored ] + return $ mkTest code root <$> tests -- hs f code | f <- hs] + +isTest :: FilePath -> Bool +isTest f = takeExtension f == ".hs" -- `elem` [".hs", ".lhs"] + + + +--------------------------------------------------------------------------- +mkTest :: ExitCode -> FilePath -> FilePath -> TestTree +--------------------------------------------------------------------------- +mkTest code dir file + = testCase file $ do + createDirectoryIfMissing True $ takeDirectory log + liquid <- canonicalizePath "dist/build/liquid/liquid" + withFile log WriteMode $ \h -> do + let cmd = testCmd liquid dir file + (_,_,_,ph) <- createProcess $ (shell cmd) {std_out = UseHandle h, std_err = UseHandle h} + c <- waitForProcess ph + assertEqual "Wrong exit code" code c + where + log = let (d,f) = splitFileName file in dir d ".liquid" f <.> "log" + + +--------------------------------------------------------------------------- +testCmd :: FilePath -> FilePath -> FilePath -> String +--------------------------------------------------------------------------- +testCmd liquid dir file = printf "cd %s && %s --verbose %s" dir liquid file + + +textIgnored = [ "Data/Text/Axioms.hs" + , "Data/Text/Encoding/Error.hs" + , "Data/Text/Encoding/Fusion.hs" + , "Data/Text/Encoding/Fusion/Common.hs" + , "Data/Text/Encoding/Utf16.hs" + , "Data/Text/Encoding/Utf32.hs" + , "Data/Text/Encoding/Utf8.hs" + , "Data/Text/Fusion/CaseMapping.hs" + , "Data/Text/Fusion/Common.hs" + , "Data/Text/Fusion/Internal.hs" + , "Data/Text/IO.hs" + , "Data/Text/IO/Internal.hs" + , "Data/Text/Lazy/Builder/Functions.hs" + , "Data/Text/Lazy/Builder/Int.hs" + , "Data/Text/Lazy/Builder/Int/Digits.hs" + , "Data/Text/Lazy/Builder/Internal.hs" + , "Data/Text/Lazy/Builder/RealFloat.hs" + , "Data/Text/Lazy/Builder/RealFloat/Functions.hs" + , "Data/Text/Lazy/Encoding/Fusion.hs" + , "Data/Text/Lazy/IO.hs" + , "Data/Text/Lazy/Read.hs" + , "Data/Text/Read.hs" + , "Data/Text/Unsafe/Base.hs" + , "Data/Text/UnsafeShift.hs" + , "Data/Text/Util.hs" + ] + + +demosIgnored = [ "Composition.hs" + , "Eval.hs" + , "Inductive.hs" + , "Loop.hs" + , "TalkingAboutSets.hs" + , "refinements101reax.hs" + ] + +---------------------------------------------------------------------------------------- +-- Generic Helpers +---------------------------------------------------------------------------------------- + +group n xs = testGroup n <$> sequence xs + +---------------------------------------------------------------------------------------- +walkDirectory :: FilePath -> IO [FilePath] +---------------------------------------------------------------------------------------- +walkDirectory root + = do (ds,fs) <- partitionM isDirectory . candidates =<< getDirectoryContents root + (fs++) <$> concatMapM walkDirectory ds + where + candidates fs = [root f | f <- fs, not (isExtSeparator (head f))] + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a],[a]) +partitionM f = go [] [] + where + go ls rs [] = return (ls,rs) + go ls rs (x:xs) = do b <- f x + if b then go (x:ls) rs xs + else go ls (x:rs) xs + +isDirectory :: FilePath -> IO Bool +isDirectory = fmap Posix.isDirectory . Posix.getFileStatus + +concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] +concatMapM f [] = pure [] +concatMapM f (x:xs) = (++) <$> f x <*> concatMapM f xs + +