packages feed

liquidhaskell 0.1 → 0.2.0.0

raw patch · 106 files changed

+25936/−17371 lines, 106 filesdep +arraydep +data-defaultdep +fingertreedep ~basedep ~ghcdep ~hashable

Dependencies added: array, data-default, fingertree, hpc, intern, liquidhaskell, optparse-applicative, tagged, tasty, tasty-hunit, tasty-rerun, template-haskell, time, unix

Dependency ranges changed: base, ghc, hashable, liquid-fixpoint

Files

− Language/Haskell/Liquid/ACSS.hs 
@@ -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 "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s-renderTypAnnot Nothing    s = s     --renderErrAnnot (Just _) s   = printf "<span class=hs-error>%s</span>" s -renderErrAnnot Nothing  s   = s--renderLinAnnot (Just d) s   = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s -renderLinAnnot Nothing  s   = s--lineString (i, w) = (replicate (w - (length is)) ' ') ++ is-  where is        = show i--{- Example Annotation:-<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>-<span class='hs-definition'>NOWTRYTHIS</span></a>--}---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-
− Language/Haskell/Liquid/ANFTransform.hs 
@@ -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))-
− Language/Haskell/Liquid/Annotate.hs 
@@ -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-  [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"-  , "<html>"-  , "<head>"-  , "<title>" ++ title ++ "</title>"-  , "</head>"-  , cssHTML css-  , "<body>"-  , "<hr>"-  , "Put mouse over identifiers to see inferred types"-  ]--htmlClose  = "\n</body>\n</html>"--cssHTML css = unlines-  [ "<head>"-  , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"-  , "</head>"-  ]----------------------------------------------------------------------------------- | 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---
− Language/Haskell/Liquid/Bare.hs 
@@ -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)
− Language/Haskell/Liquid/CTags.hs 
@@ -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 --
− Language/Haskell/Liquid/CmdLine.hs 
@@ -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
− Language/Haskell/Liquid/Constraint.hs 
@@ -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]
− Language/Haskell/Liquid/Desugar/Desugar.lhs 
@@ -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}
− Language/Haskell/Liquid/Desugar/DsArrows.lhs 
@@ -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}
− Language/Haskell/Liquid/Desugar/DsBinds.lhs 
@@ -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 = <poly_rhs>--From this the typechecker generates--    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds--    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX-                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])--Note that wrap_fn can transform *any* function with the right type prefix -    forall ab. (Eq a, Ix b) => XXX-regardless of XXX.  It's sort of polymorphic in XXX.  This is-useful: we use the same wrapper to transform each of the class ops, as-well as the dict.--From these we generate:--    Rule: 	forall p, q, (dp:Ix p), (dq:Ix q). -                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq--    Spec bind:	f_spec = wrap_fn <poly_rhs>--Note that --  * The LHS of the rule may mention dictionary *expressions* (eg-    $dfIxPair dp dq), and that is essential because the dp, dq are-    needed on the RHS.--  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it -    can fully specialise it.--\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 = <rhs>-	{-# SPECIALISE f :: Int -> Int #-}--Then we get the SpecPrag-	SpecPrag (f Int dInt) --And from that we want the rule-	-	RULE forall dInt. f Int dInt = f_spec-	f_spec = let f = <rhs> in f Int dInt--But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External-Name, and you can't bind them in a lambda or forall without getting things-confused.   Likewise it might have an InlineRule or something, which would be-utterly bogus. So we really make a fresh Id, with the same unique and type-as the old one, but with an Internal name and no IdInfo.---%************************************************************************-%*									*-		Desugaring evidence-%*									*-%************************************************************************---\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}
− Language/Haskell/Liquid/Desugar/DsExpr.lhs 
@@ -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}
− Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot 
@@ -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}
− Language/Haskell/Liquid/Desugar/DsGRHSs.lhs 
@@ -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}
− Language/Haskell/Liquid/Desugar/DsListComp.lhs 
@@ -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 <<e>> TE <<L>>--(Rule B)-TQ << [ e | b , qs ] ++ L >> =-    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>--(Rule A')-TQ << [ e | p <- L1, qs ]  ++  L2 >> =-  letrec-    h = \ u1 ->-          case u1 of-            []        ->  TE << L2 >>-            (u2 : u3) ->-                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)-                    [] (h u3)-  in-    h ( TE << L1 >> )--"h", "u1", "u2", and "u3" are new variables.-\end{verbatim}--@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@-is the TE translation scheme.  Note that we carry around the @L@ list-already desugared.  @dsListComp@ does the top TE rule mentioned above.--To the above, we add an additional rule to deal with parallel list-comprehensions.  The translation goes roughly as follows:-     [ e | p1 <- e11, let v1 = e12, p2 <- e13-         | q1 <- e21, let v2 = e22, q2 <- e23]-     =>-     [ e | ((x1, .., xn), (y1, ..., ym)) <--               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]-                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]-where (x1, .., xn) are the variables bound in p1, v1, p2-      (y1, .., ym) are the variables bound in q1, v2, q2--In the translation below, the ParStmt branch translates each parallel branch-into a sub-comprehension, and desugars each independently.  The resulting lists-are fed to a zip function, we create a binding for all the variables bound in all-the comprehensions, and then we hand things off the the desugarer for bindings.-The zip function is generated here a) because it's small, and b) because then we-don't have to deal with arbitrary limits on the number of zip functions in the-prelude, nor which library the zip function came from.-The introduced tuples are Boxed, but only because I couldn't get it to work-with the Unboxed variety.--\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}
− Language/Haskell/Liquid/Desugar/DsUtils.lhs 
@@ -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}
− Language/Haskell/Liquid/Desugar/HscMain.hs 
@@ -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)
− Language/Haskell/Liquid/Desugar/Match.lhs 
@@ -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 <binds>-in  <matching-code>-\end{verbatim}-\item-and finally: (ToDo: fill in)--The right way to think about the ``after-match function'' is that it-is an embryonic @CoreExpr@ with a ``hole'' at the end for the-final ``else expression''.-\end{itemize}--There is a type synonym, @EquationInfo@, defined in module @DsUtils@.--An experiment with re-ordering this information about equations (in-particular, having the patterns available in column-major order)-showed no benefit.--\item-A default expression---what to evaluate if the overall pattern-match-fails.  This expression will (almost?) always be-a measly expression @Var@, unless we know it will only be used once-(as we do in @glue_success_exprs@).--Leaving out this third argument to @match@ (and slamming in lots of-@Var "fail"@s) is a positively {\em bad} idea, because it makes it-impossible to share the default expressions.  (Also, it stands no-chance of working in our post-upheaval world of @Locals@.)-\end{enumerate}--Note: @match@ is often called via @matchWrapper@ (end of this module),-a function that does much of the house-keeping that goes with a call-to @match@.--It is also worth mentioning the {\em typical} way a block of equations-is desugared with @match@.  At each stage, it is the first column of-patterns that is examined.  The steps carried out are roughly:-\begin{enumerate}-\item-Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add-bindings to the second component of the equation-info):-\begin{itemize}-\item-Remove the `as' patterns from column~1.-\item-Make all constructor patterns in column~1 into @ConPats@, notably-@ListPats@ and @TuplePats@.-\item-Handle any irrefutable (or ``twiddle'') @LazyPats@.-\end{itemize}-\item-Now {\em unmix} the equations into {\em blocks} [w\/ local function-@unmix_eqns@], in which the equations in a block all have variable-patterns in column~1, or they all have constructor patterns in ...-(see ``the mixture rule'' in SLPJ).-\item-Call @matchEqnBlock@ on each block of equations; it will do the-appropriate thing for each kind of column-1 pattern, usually ending up-in a recursive call to @match@.-\end{enumerate}--We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)-than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).-And gluing the ``success expressions'' together isn't quite so pretty.--This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@-(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and-(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em-un}mixes the equations], producing a list of equation-info-blocks, each block having as its first column of patterns either all-constructors, or all variables (or similar beasts), etc.--@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the-Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@-corresponds roughly to @matchVarCon@.--\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.-
− Language/Haskell/Liquid/Desugar/Match.lhs-boot 
@@ -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}
− Language/Haskell/Liquid/Desugar/MatchCon.lhs 
@@ -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.  -
− Language/Haskell/Liquid/Desugar/MatchLit.lhs 
@@ -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  <expr-for-a-successful-match>-    else-	<try-next-pattern-or-whatever>-\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}
− Language/Haskell/Liquid/DiffCheck.hs 
@@ -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
− Language/Haskell/Liquid/Fresh.hs 
@@ -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
− Language/Haskell/Liquid/GhcInterface.hs 
@@ -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 ] -
− Language/Haskell/Liquid/GhcMisc.hs 
@@ -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 }
− Language/Haskell/Liquid/Measure.hs 
@@ -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)--
− Language/Haskell/Liquid/Misc.hs 
@@ -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"
− Language/Haskell/Liquid/Parse.hs 
@@ -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)--}
− Language/Haskell/Liquid/PredType.hs 
@@ -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)-
− Language/Haskell/Liquid/Predicates.hs 
@@ -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-
− Language/Haskell/Liquid/PrettyPrint.hs 
@@ -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--
− Language/Haskell/Liquid/Qualifier.hs 
@@ -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]--
− Language/Haskell/Liquid/RefType.hs 
@@ -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)----
− Language/Haskell/Liquid/Tidy.hs 
@@ -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)     = []-
− Language/Haskell/Liquid/TransformRec.hs 
@@ -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)
− Language/Haskell/Liquid/Types.hs 
@@ -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 <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>---   = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)--- 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)-
Liquid.hs view
@@ -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+
include/Control/Exception.spec view
@@ -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
+ include/Data/Bits.spec view
@@ -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)) }+
+ include/Data/Either.spec view
@@ -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
include/Data/List.spec view
@@ -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)
include/Data/Set.spec view
@@ -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)) }
include/Data/Vector.spec view
@@ -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) }
include/Foreign/C/Types.spec view
@@ -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
include/Foreign/ForeignPtr.spec view
@@ -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)))
include/Foreign/Ptr.spec view
@@ -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) }
include/Foreign/Storable.spec view
@@ -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)
include/GHC/Base.spec view
@@ -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}
include/GHC/Classes.spec view
@@ -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) }
include/GHC/ForeignPtr.spec view
@@ -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))
include/GHC/Int.spec view
@@ -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
− include/GHC/List.lhs 
@@ -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 <len.hquals> @-}-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}
+ include/GHC/List.spec view
@@ -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 <len.hquals>++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
include/GHC/Prim.spec view
@@ -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)}
include/GHC/Ptr.spec view
@@ -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)
+ include/GHC/Read.spec view
@@ -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))]
include/GHC/Real.spec view
@@ -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) }
include/GHC/Types.spec view
@@ -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)))}
+ include/Language/Haskell/Liquid/Foreign.hs view
@@ -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
include/Language/Haskell/Liquid/Prelude.hs view
@@ -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 <p :: a -> Prop>. (a<p> -> {v:Bool| ((Prop v) <=> true)}) -> a -> a<p> @-}+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]
+ include/NotReal.spec view
@@ -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
include/Prelude.hquals view
@@ -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])
include/Prelude.spec view
@@ -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<p x>) ->@@ -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}>
+ include/Real.spec view
@@ -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) }
liquidhaskell.cabal view
@@ -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 <jhala@cs.ucsd.edu> 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
+ src/Language/Haskell/Liquid/ACSS.hs view
@@ -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 "<a class=annot href=\"#\"><span class=annottext>%s</span>%s</a>" (escape ann) s+renderTypAnnot Nothing    s = s     ++renderErrAnnot (Just _) s   = printf "<span class=hs-error>%s</span>" s +renderErrAnnot Nothing  s   = s++renderLinAnnot (Just d) s   = printf "<span class=hs-linenum>%s: </span>%s" (lineString d) s +renderLinAnnot Nothing  s   = s++lineString (i, w) = (replicate (w - (length is)) ' ') ++ is+  where is        = show i++{- Example Annotation:+<a class=annot href="#"><span class=annottext>x#agV:Int -&gt; {VV_int:Int | (0 &lt;= VV_int),(x#agV &lt;= VV_int)}</span>+<span class='hs-definition'>NOWTRYTHIS</span></a>+-}+++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+
+ src/Language/Haskell/Liquid/ANFTransform.hs view
@@ -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))+
+ src/Language/Haskell/Liquid/Annotate.hs view
@@ -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+  [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"+  , "<html>"+  , "<head>"+  , "<title>" ++ title ++ "</title>"+  , "</head>"+  , cssHTML css+  , "<body>"+  , "<hr>"+  , "Put mouse over identifiers to see inferred types"+  ]++htmlClose  = "\n</body>\n</html>"++cssHTML css = unlines+  [ "<head>"+  , "<link type='text/css' rel='stylesheet' href='"++ css ++ "' />"+  , "</head>"+  ]++------------------------------------------------------------------------------+-- | 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+++
+ src/Language/Haskell/Liquid/Bare.hs view
@@ -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)
+ src/Language/Haskell/Liquid/CTags.hs view
@@ -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 ++
+ src/Language/Haskell/Liquid/CmdLine.hs view
@@ -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+
+ src/Language/Haskell/Liquid/Constraint.hs view
@@ -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
+ src/Language/Haskell/Liquid/Desugar/Check.lhs view
@@ -0,0 +1,765 @@+%+% (c) The University of Glasgow 2006+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998+%+% Author: Juan J. Quintela    <quintela@krilin.dc.fi.udc.es>++\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}
+ src/Language/Haskell/Liquid/Desugar/Coverage.lhs view
@@ -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 -- <tab> counts as a normal char in GHC's location ranges.++        createDirectoryIfMissing True hpc_mod_dir+        modTime <- getModificationUTCTime filename+        let entries' = [ (hpcPos, box)+                       | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]+        when (length entries' /= count) $ do+          panic "the number of .mix entries are inconsistent"+        let hashNo = mixHash filename modTime tabStop entries'+        mixCreate hpc_mod_dir mod_name+                       $ Mix filename modTime (toHash hashNo) tabStop entries'+        return hashNo+++-- -----------------------------------------------------------------------------+-- TickDensity: where to insert ticks++data TickDensity+  = TickForCoverage       -- for Hpc+  | TickForBreakPoints    -- for GHCi+  | TickAllFunctions      -- for -prof-auto-all+  | TickTopFunctions      -- for -prof-auto-top+  | TickExportedFunctions -- for -prof-auto-exported+  | TickCallSites         -- for stack tracing+  deriving Eq++mkDensity :: 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_<module>()`, which is emitted into the _stub.c file+and annotated with __attribute__((constructor)) so that it gets+executed at startup time.++The function's purpose is to call hs_hpc_module to register this+module with the RTS, and it looks something like this:++static void hpc_init_Main(void) __attribute__((constructor));+static void hpc_init_Main(void)+{extern StgWord64 _hpc_tickboxes_Main_hpc[];+ hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);}++\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}
+ src/Language/Haskell/Liquid/Desugar/Desugar.lhs view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/DsArrows.lhs view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/DsBinds.lhs view
@@ -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 = <poly_rhs>++From this the typechecker generates++    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds++    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])++Note that wrap_fn can transform *any* function with the right type prefix +    forall ab. (Eq a, Ix b) => XXX+regardless of XXX.  It's sort of polymorphic in XXX.  This is+useful: we use the same wrapper to transform each of the class ops, as+well as the dict.++From these we generate:++    Rule: 	forall p, q, (dp:Ix p), (dq:Ix q). +                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq++    Spec bind:	f_spec = wrap_fn <poly_rhs>++Note that ++  * The LHS of the rule may mention dictionary *expressions* (eg+    $dfIxPair dp dq), and that is essential because the dp, dq are+    needed on the RHS.++  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it +    can fully specialise it.++\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 = <rhs>+	{-# SPECIALISE f :: Int -> Int #-}++Then we get the SpecPrag+	SpecPrag (f Int dInt) ++And from that we want the rule+	+	RULE forall dInt. f Int dInt = f_spec+	f_spec = let f = <rhs> in f Int dInt++But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External+Name, and you can't bind them in a lambda or forall without getting things+confused.   Likewise it might have an InlineRule or something, which would be+utterly bogus. So we really make a fresh Id, with the same unique and type+as the old one, but with an Internal name and no IdInfo.+++%************************************************************************+%*									*+		Desugaring evidence+%*									*+%************************************************************************+++\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.++
+ src/Language/Haskell/Liquid/Desugar/DsExpr.lhs view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/DsExpr.lhs-boot view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/DsForeign.lhs view
@@ -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'' <arg info> 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}
+ src/Language/Haskell/Liquid/Desugar/DsGRHSs.lhs view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/DsListComp.lhs view
@@ -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 <<e>> TE <<L>>++(Rule B)+TQ << [ e | b , qs ] ++ L >> =+    if TE << b >> then TQ << [ e | qs ] ++ L >> else TE << L >>++(Rule A')+TQ << [ e | p <- L1, qs ]  ++  L2 >> =+  letrec+    h = \ u1 ->+          case u1 of+            []        ->  TE << L2 >>+            (u2 : u3) ->+                  (( \ TE << p >> -> ( TQ << [e | qs]  ++  (h u3) >> )) u2)+                    [] (h u3)+  in+    h ( TE << L1 >> )++"h", "u1", "u2", and "u3" are new variables.+\end{verbatim}++@deListComp@ is the TQ translation scheme.  Roughly speaking, @dsExpr@+is the TE translation scheme.  Note that we carry around the @L@ list+already desugared.  @dsListComp@ does the top TE rule mentioned above.++To the above, we add an additional rule to deal with parallel list+comprehensions.  The translation goes roughly as follows:+     [ e | p1 <- e11, let v1 = e12, p2 <- e13+         | q1 <- e21, let v2 = e22, q2 <- e23]+     =>+     [ e | ((x1, .., xn), (y1, ..., ym)) <-+               zip [(x1,..,xn) | p1 <- e11, let v1 = e12, p2 <- e13]+                   [(y1,..,ym) | q1 <- e21, let v2 = e22, q2 <- e23]]+where (x1, .., xn) are the variables bound in p1, v1, p2+      (y1, .., ym) are the variables bound in q1, v2, q2++In the translation below, the ParStmt branch translates each parallel branch+into a sub-comprehension, and desugars each independently.  The resulting lists+are fed to a zip function, we create a binding for all the variables bound in all+the comprehensions, and then we hand things off the the desugarer for bindings.+The zip function is generated here a) because it's small, and b) because then we+don't have to deal with arbitrary limits on the number of zip functions in the+prelude, nor which library the zip function came from.+The introduced tuples are Boxed, but only because I couldn't get it to work+with the Unboxed variety.++\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}
+ src/Language/Haskell/Liquid/Desugar/DsMeta.hs view
@@ -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 <module>:<name> form) for the associated entity+--+lookupLOcc :: Located Name -> DsM (Core TH.Name)+-- Lookup an occurrence; it can't be a splice.+-- Use the in-scope bindings if they exist+lookupLOcc (L _ n) = lookupOcc n++lookupOcc :: Name -> DsM (Core TH.Name)+lookupOcc n+  = do {  mb_val <- dsLookupMetaEnv n ;+          case mb_val of+                Nothing         -> globalVar n+                Just (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
+ src/Language/Haskell/Liquid/Desugar/DsUtils.lhs view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/HscMain.hs view
@@ -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
+ src/Language/Haskell/Liquid/Desugar/Match.lhs view
@@ -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 <binds>+in  <matching-code>+\end{verbatim}+\item+and finally: (ToDo: fill in)++The right way to think about the ``after-match function'' is that it+is an embryonic @CoreExpr@ with a ``hole'' at the end for the+final ``else expression''.+\end{itemize}++There is a type synonym, @EquationInfo@, defined in module @DsUtils@.++An experiment with re-ordering this information about equations (in+particular, having the patterns available in column-major order)+showed no benefit.++\item+A default expression---what to evaluate if the overall pattern-match+fails.  This expression will (almost?) always be+a measly expression @Var@, unless we know it will only be used once+(as we do in @glue_success_exprs@).++Leaving out this third argument to @match@ (and slamming in lots of+@Var "fail"@s) is a positively {\em bad} idea, because it makes it+impossible to share the default expressions.  (Also, it stands no+chance of working in our post-upheaval world of @Locals@.)+\end{enumerate}++Note: @match@ is often called via @matchWrapper@ (end of this module),+a function that does much of the house-keeping that goes with a call+to @match@.++It is also worth mentioning the {\em typical} way a block of equations+is desugared with @match@.  At each stage, it is the first column of+patterns that is examined.  The steps carried out are roughly:+\begin{enumerate}+\item+Tidy the patterns in column~1 with @tidyEqnInfo@ (this may add+bindings to the second component of the equation-info):+\begin{itemize}+\item+Remove the `as' patterns from column~1.+\item+Make all constructor patterns in column~1 into @ConPats@, notably+@ListPats@ and @TuplePats@.+\item+Handle any irrefutable (or ``twiddle'') @LazyPats@.+\end{itemize}+\item+Now {\em unmix} the equations into {\em blocks} [w\/ local function+@unmix_eqns@], in which the equations in a block all have variable+patterns in column~1, or they all have constructor patterns in ...+(see ``the mixture rule'' in SLPJ).+\item+Call @matchEqnBlock@ on each block of equations; it will do the+appropriate thing for each kind of column-1 pattern, usually ending up+in a recursive call to @match@.+\end{enumerate}++We are a little more paranoid about the ``empty rule'' (SLPJ, p.~87)+than the Wadler-chapter code for @match@ (p.~93, first @match@ clause).+And gluing the ``success expressions'' together isn't quite so pretty.++This (more interesting) clause of @match@ uses @tidy_and_unmix_eqns@+(a)~to get `as'- and `twiddle'-patterns out of the way (tidying), and+(b)~to do ``the mixture rule'' (SLPJ, p.~88) [which really {\em+un}mixes the equations], producing a list of equation-info+blocks, each block having as its first column of patterns either all+constructors, or all variables (or similar beasts), etc.++@match_unmixed_eqn_blks@ simply takes the place of the @foldr@ in the+Wadler-chapter @match@ (p.~93, last clause), and @match_unmixed_blk@+corresponds roughly to @matchVarCon@.++\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.+
+ src/Language/Haskell/Liquid/Desugar/Match.lhs-boot view
@@ -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}
+ src/Language/Haskell/Liquid/Desugar/MatchCon.lhs view
@@ -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.  +
+ src/Language/Haskell/Liquid/Desugar/MatchLit.lhs view
@@ -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  <expr-for-a-successful-match>+    else+        <try-next-pattern-or-whatever>+\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}
+ src/Language/Haskell/Liquid/DiffCheck.hs view
@@ -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+
+ src/Language/Haskell/Liquid/Errors.hs view
@@ -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
+ src/Language/Haskell/Liquid/Fresh.hs view
@@ -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+
+ src/Language/Haskell/Liquid/GhcInterface.hs view
@@ -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)] +
+ src/Language/Haskell/Liquid/GhcMisc.hs view
@@ -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
+ src/Language/Haskell/Liquid/Measure.hs view
@@ -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)++
+ src/Language/Haskell/Liquid/Misc.hs view
@@ -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+                        +
+ src/Language/Haskell/Liquid/Parse.hs view
@@ -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)+-}
+ src/Language/Haskell/Liquid/PredType.hs view
@@ -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)+
+ src/Language/Haskell/Liquid/PrettyPrint.hs view
@@ -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+++
+ src/Language/Haskell/Liquid/Qualifier.hs view
@@ -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]++
+ src/Language/Haskell/Liquid/RefType.hs view
@@ -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)+
+ src/Language/Haskell/Liquid/Strata.hs view
@@ -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++
+ src/Language/Haskell/Liquid/Tidy.hs view
@@ -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)     = []+
+ src/Language/Haskell/Liquid/TransformRec.hs view
@@ -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)
+ src/Language/Haskell/Liquid/Types.hs view
@@ -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 <p :: b -> Prop, q :: Int -> Prop, r :: a -> Prop>+--       = F (a<r> -> b<p>) | Q (c -> a) | G (Int<q> -> a<r>)+--+--  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
+ src/Language/Haskell/Liquid/World.hs view
@@ -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++
+ tests/test.hs view
@@ -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++