packages feed

liquidhaskell (empty) → 0.1

raw patch · 82 files changed

+18352/−0 lines, 82 filesdep +Diffdep +aesondep +ansi-terminalsetup-changed

Dependencies added: Diff, aeson, ansi-terminal, base, bifunctors, bytestring, cmdargs, containers, cpphs, deepseq, directory, filemanip, filepath, ghc, ghc-paths, hashable, hscolour, liquid-fixpoint, mtl, parsec, pretty, process, syb, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,24 @@+(*+ * Copyright © 1990-2009 The Regents of the University of California. All rights reserved. + *+ * Permission is hereby granted, without written agreement and without + * license or royalty fees, to use, copy, modify, and distribute this + * software and its documentation for any purpose, provided that the + * above copyright notice and the following two paragraphs appear in + * all copies of this software. + * + * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY + * FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES + * ARISING OUT OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN + * IF THE UNIVERSITY OF CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY + * OF SUCH DAMAGE. + * + * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES, + * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY + * AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS + * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION + * TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.+ *+ *)++
+ Language/Haskell/Liquid/ACSS.hs view
@@ -0,0 +1,287 @@+-- | 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 view
@@ -0,0 +1,216 @@+{-# 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 view
@@ -0,0 +1,451 @@+{-# 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 view
@@ -0,0 +1,1338 @@+{-# 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 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 ++
+ Language/Haskell/Liquid/CmdLine.hs view
@@ -0,0 +1,232 @@+{-# 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 view
@@ -0,0 +1,1415 @@+{-# 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 view
@@ -0,0 +1,437 @@+%+% (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 view
@@ -0,0 +1,1132 @@+%+% (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 view
@@ -0,0 +1,864 @@+%+% (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 view
@@ -0,0 +1,883 @@+%+% (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 view
@@ -0,0 +1,19 @@+\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 view
@@ -0,0 +1,160 @@+%+% (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 view
@@ -0,0 +1,879 @@+%+% (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 view
@@ -0,0 +1,806 @@+%+% (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 view
@@ -0,0 +1,55 @@+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 view
@@ -0,0 +1,982 @@+%+% (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 view
@@ -0,0 +1,42 @@+\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 view
@@ -0,0 +1,262 @@+%+% (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 view
@@ -0,0 +1,328 @@+%+% (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 view
@@ -0,0 +1,213 @@+-- | 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 view
@@ -0,0 +1,116 @@+{-# 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 view
@@ -0,0 +1,501 @@++{-# 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 view
@@ -0,0 +1,290 @@+{-# 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 view
@@ -0,0 +1,297 @@+{-# 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 view
@@ -0,0 +1,40 @@+{-# 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 view
@@ -0,0 +1,719 @@+{-# 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 view
@@ -0,0 +1,431 @@+{-# 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 view
@@ -0,0 +1,112 @@+{-# 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 view
@@ -0,0 +1,204 @@+{-# 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 view
@@ -0,0 +1,125 @@+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 view
@@ -0,0 +1,1051 @@+{-# 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 view
@@ -0,0 +1,101 @@+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 view
@@ -0,0 +1,255 @@+{-# 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 view
@@ -0,0 +1,1069 @@+{-# 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
@@ -0,0 +1,97 @@+{-# 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++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 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   ++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)+++liquidOne target info = +  do donePhase Loud "Extracted Core From GHC"+     let cfg   = config $ spec info +     whenLoud  $ do putStrLn $ showpp info +                    putStrLn "*************** Original CoreBinds ***************************" +                    putStrLn $ showpp (cbs info)+     let cbs' = transformRecExpr (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''}+     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 +     donePhase Loud "solve"+     let out   = Just $ O (checkedNames pruned cbs'') (logWarn cgi) sol (annotMap cgi)+     exitWithResult target out (result $ sinfo <$> r) ++checkedNames False _    = Nothing+checkedNames True cbs   = Just $ concatMap names cbs+  where+    names (NonRec v _ ) = [varName v]+    names (Rec bs)      = map (varName . fst) bs++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)+  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 }++writeCGI tgt cgi = {-# SCC "ConsWrite" #-} writeFile (extFileName Cgi tgt) str+  where +    str          = {-# SCC "PPcgi" #-} showFix cgi+
+ Setup.hs view
@@ -0,0 +1,9 @@+import Distribution.Simple++main = defaultMain++-- main = defaultMainWithHooks fixpointHooks +--  +-- fixpointHooks   = defaultUserHooks { postInst = cpFix }+--    where +--      cpFix _ _ _ lbi = putStrLn $ "CPFIXSAYS: " ++ show lbi
+ include/Bot.hquals view
@@ -0,0 +1,8 @@+//BOT: Do not delete EVER!++qualif Bot(v:@(0))    : 0 = 1 +qualif Bot(v:obj)     : 0 = 1 +qualif Bot(v:a)       : 0 = 1 +qualif Bot(v:bool)    : 0 = 1 +qualif Bot(v:int)     : 0 = 1 +
+ include/Control/Exception.spec view
@@ -0,0 +1,7 @@+module spec Control.Exception where++-- Useless as compiled into GHC primitive, which is ignored+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/Control/Monad.spec view
@@ -0,0 +1,3 @@+module spec Control.Monad where++sequence :: GHC.Base.Monad m => xs:[m a] -> m {v:[a] | (len v) = (len xs)}
+ include/Data/Int.spec view
@@ -0,0 +1,2 @@+module spec Data.Int where+
+ include/Data/List.spec view
@@ -0,0 +1,18 @@+module spec Data.List where++import GHC.List++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)++qualif SumLensEq(v:List List a, x:List a): (sumLens v) = (len x)+
+ include/Data/Maybe.spec view
@@ -0,0 +1,8 @@+module spec Data.Maybe where++measure isJust :: forall a. Data.Maybe.Maybe a -> Prop+isJust (Data.Maybe.Just x)  = true+isJust (Data.Maybe.Nothing) = false++measure fromJust :: forall a. Data.Maybe.Maybe a -> a+fromJust (Data.Maybe.Just x) = x
+ include/Data/Set.spec view
@@ -0,0 +1,53 @@+module spec Data.Set where++embed Data.Set.Set as Set_Set++----------------------------------------------------------------------------------------------+-- | Logical Set Operators: Interpreted "natively" by the SMT solver -------------------------+----------------------------------------------------------------------------------------------++-- | union+measure Set_cup  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)++-- | intersection+measure Set_cap  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)++-- | difference+measure Set_dif  :: (Data.Set.Set a) -> (Data.Set.Set a) -> (Data.Set.Set a)++-- | singleton+measure Set_sng  :: a -> (Data.Set.Set a)++-- | emptiness test+measure Set_emp  :: (Data.Set.Set a) -> Prop++-- | membership test+measure Set_mem  :: a -> (Data.Set.Set a) -> Prop++-- | inclusion test+measure Set_sub  :: (Data.Set.Set a) -> (Data.Set.Set a) -> Prop ++---------------------------------------------------------------------------------------------+-- | Refined Types for Data.Set Operations --------------------------------------------------+---------------------------------------------------------------------------------------------++isSubsetOf    :: (GHC.Classes.Ord a) => x:(Data.Set.Set a) -> y:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_sub x y))}+member        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:Bool | ((Prop v) <=> (Set_mem x xs))}++empty         :: {v:(Data.Set.Set a) | (Set_emp v)}+singleton     :: x:a -> {v:(Data.Set.Set a) | v = (Set_sng x)}+insert        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cup xs (Set_sng x))}+delete        :: (GHC.Classes.Ord a) => x:a -> xs:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_dif xs (Set_sng x))}++union         :: GHC.Classes.Ord a => xs:(Data.Set.Set a) -> ys:(Data.Set.Set a) -> {v:(Data.Set.Set a) | v = (Set_cup xs ys)}+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)}+++---------------------------------------------------------------------------------------------+-- | The set of elements in a list ----------------------------------------------------------+---------------------------------------------------------------------------------------------++measure listElts :: [a] -> (Data.Set.Set a) +listElts([])   = {v | (? Set_emp(v))}+listElts(x:xs) = {v | v = (Set_cup (Set_sng x) (listElts xs)) }
+ include/Data/Text/Fusion.spec view
@@ -0,0 +1,25 @@+module spec Data.Text.Fusion where++import Data.Text.Fusion.Common++stream        :: t:Data.Text.Internal.Text+              -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}+reverseStream :: t:Data.Text.Internal.Text+              -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (tlength t)}+unstream      :: s:Data.Text.Fusion.Internal.Stream Char+              -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}++findIndex :: (GHC.Types.Char -> GHC.Types.Bool)+          -> s:Data.Text.Fusion.Internal.Stream Char+          -> (Data.Maybe.Maybe {v:Nat | v < (slen s)})++mapAccumL :: (a -> GHC.Types.Char -> (a,GHC.Types.Char))+          -> a+          -> s:Data.Text.Fusion.Internal.Stream Char+          -> (a, {v:Data.Text.Internal.Text | (tlength v) = (slen s)})+++length  :: s:Data.Text.Fusion.Internal.Stream Char+        -> {v:GHC.Types.Int | v = (slen s)}+reverse :: s:Data.Text.Fusion.Internal.Stream Char+        -> {v:Data.Text.Internal.Text | (tlength v) = (slen s)}
+ include/Data/Text/Fusion/Common.spec view
@@ -0,0 +1,47 @@+module spec Data.Text.Fusion.Common where++measure slen :: Data.Text.Fusion.Internal.Stream a+             -> GHC.Types.Int++cons :: GHC.Types.Char+     -> s:Data.Text.Fusion.Internal.Stream Char+     -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}+snoc :: s:Data.Text.Fusion.Internal.Stream Char+     -> GHC.Types.Char+     -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (1 + (slen s))}++compareLengthI :: s:Data.Text.Fusion.Internal.Stream Char+               -> l:GHC.Types.Int+               -> {v:GHC.Types.Ordering | ((v = GHC.Types.EQ) <=> ((slen s) = l))}++isSingleton :: s:Data.Text.Fusion.Internal.Stream Char+            -> {v:GHC.Types.Bool | ((Prop v) <=> ((slen s) = 1))}+singleton   :: GHC.Types.Char+            -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = 1}++streamList   :: l:[a]+             -> {v:Data.Text.Fusion.Internal.Stream a | (slen v) = (len l)}+unstreamList :: s:Data.Text.Fusion.Internal.Stream a+             -> {v:[a] | (len v) = (slen s)}++map :: (GHC.Types.Char -> GHC.Types.Char)+    -> s:Data.Text.Fusion.Internal.Stream Char+    -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (slen s)}+filter :: (GHC.Types.Char -> GHC.Types.Bool)+       -> s:Data.Text.Fusion.Internal.Stream Char+       -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) <= (slen s)}++intersperse :: GHC.Types.Char+            -> s:Data.Text.Fusion.Internal.Stream Char+            -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) > (slen s)}++replicateCharI :: l:GHC.Types.Int+               -> GHC.Types.Char+               -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = l}++toCaseFold :: s:Data.Text.Fusion.Internal.Stream Char+           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}+toUpper    :: s:Data.Text.Fusion.Internal.Stream Char+           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}+toLower    :: s:Data.Text.Fusion.Internal.Stream Char+           -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) >= (slen s)}
+ include/Data/Text/Lazy/Fusion.spec view
@@ -0,0 +1,8 @@+module spec Data.Text.Lazy.Fusion where++stream :: t:Data.Text.Lazy.Internal.Text+       -> {v:Data.Text.Fusion.Internal.Stream Char | (slen v) = (ltlength t)}+unstream :: s:Data.Text.Fusion.Internal.Stream Char+         -> {v:Data.Text.Lazy.Internal.Text | (ltlength v) = (slen s)}+length :: s:Data.Text.Fusion.Internal.Stream Char+       -> {v:GHC.Int.Int64 | v = (slen s)}
+ include/Data/Vector.hquals view
@@ -0,0 +1,3 @@+qualif VecEmpty(v: Vector a)              : vlen([v]) [ = ; > ; >= ]  0 +qualif Vlen(v:int, ~A: Vector a)          : v [ = ; <= ; < ]  vlen([~A]) +qualif CmpVlen(v: Vector a, ~A: Vector b) : vlen([v]) [ < ; <= ; > ; >= ; = ] vlen([~A])
+ include/Data/Vector.spec view
@@ -0,0 +1,13 @@+module spec Data.Vector where++import GHC.Base++measure vlen    :: forall a. (Vector a) -> Int++invariant       {v: Vector a | (vlen v) >= 0 } ++assume !        :: forall a. x:(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 length   :: forall a. x:(Vector a) -> {v: Int | (v = (vlen x) && v >= 0) }
+ include/Data/Word.spec view
@@ -0,0 +1,3 @@+module spec Data.Word where++import GHC.Word
+ include/Foreign/C/String.spec view
@@ -0,0 +1,9 @@+module spec Foreign.C.String where++import Foreign.Ptr++type CStringLen    = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), Nat)<{\p v -> (v <= (plen p))}>+type CStringLenN N = ((GHC.Ptr.Ptr Foreign.C.Types.CChar), {v:Nat | v = N})<{\p v -> (v <= (plen p))}>++measure cStringLen :: Foreign.C.String.CStringLen -> Int+cStringLen (c, n) = n
+ include/Foreign/C/Types.spec view
@@ -0,0 +1,8 @@+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
@@ -0,0 +1,20 @@+module spec Foreign.ForeignPtr where++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)))++Foreign.ForeignPtr.newForeignPtr :: Foreign.ForeignPtr.FinalizerPtr a -> p:(PtrV a) -> (GHC.Types.IO (ForeignPtrN a (plen p)))++-- this uses `sizeOf (undefined :: a)`, so the ForeignPtr does not necessarily have length `n`+-- Foreign.ForeignPtr.Imp.mallocForeignPtrArray :: (Foreign.Storable.Storable a) => n:Nat -> IO (ForeignPtrN a n)
+ include/Foreign/Marshal/Alloc.spec view
@@ -0,0 +1,3 @@+module spec Foreign.Marshal.Alloc where++Foreign.Marshal.Alloc.allocaBytes :: n:Nat -> (PtrN a n -> IO b) -> IO b
+ include/Foreign/Marshal/Array.spec view
@@ -0,0 +1,3 @@+module spec Foreign.Marshal.Array where++Foreign.Marshal.Array.allocaArray :: Foreign.Storable.Storable a => n:Int -> ((PtrN a n) -> IO b) -> IO b
+ include/Foreign/Ptr.spec view
@@ -0,0 +1,10 @@+module spec Foreign.Ptr where++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
@@ -0,0 +1,25 @@+module spec Foreign.Storable where++predicate PValid P N         = ((0 <= N) && (N < (plen P)))   ++Foreign.Storable.poke        :: (Foreign.Storable.Storable a)+                             => {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)}+                             -> (GHC.Types.IO {v:a | v = (deref p)})++Foreign.Storable.peekByteOff :: (Foreign.Storable.Storable a)+                             => forall b. p:(GHC.Ptr.Ptr b)+                             -> {v:GHC.Types.Int | (PValid p v)}+                             -> (GHC.Types.IO a)++Foreign.Storable.pokeByteOff :: (Foreign.Storable.Storable a)+                             => forall b. p:(GHC.Ptr.Ptr b)+                             -> {v:GHC.Types.Int | (PValid p v)}+                             -> a+                             -> GHC.Types.IO ()++
+ include/GHC/Base.hquals view
@@ -0,0 +1,11 @@+//qualif NonNull(v: [a])        : (? (nonnull([v])))+//qualif Null(v: [a])           : (~ (? (nonnull([v]))))+//qualif EqNull(v:Bool, ~A: [a]): (Prop(v) <=> (? (nonnull([~A]))))++qualif IsEmp(v:GHC.Types.Bool, ~A: [a]) : (Prop(v) <=> len([~A]) [ > ;  = ] 0)+qualif ListZ(v: [a])          : len([v]) [ = ; >= ; > ] 0 +qualif CmpLen(v:[a], ~A:[b])  : len([v]) [= ; >=; >; <=; <] len([~A]) +qualif EqLen(v:int, ~A: [a])  : v = len([~A]) +qualif LenEq(v:[a], ~A: int)  : ~A = len([v]) +qualif LenAcc(v:int, ~A:[a], ~B: int): v = len([~A]) + ~B+qualif LenDiff(v:[a], ~A:int): len([v]) = (~A [ +; - ] 1)
+ include/GHC/Base.spec view
@@ -0,0 +1,33 @@+module spec GHC.Base where++import GHC.Prim+import GHC.Classes+import GHC.Types+import GHC.Err  ++embed GHC.Types.Int      as int+embed Prop               as bool++measure Prop   :: GHC.Types.Bool -> Prop++measure len :: forall a. [a] -> GHC.Types.Int+len ([])     = 0+len (y:ys)   = 1 + (len ys)++measure null :: forall a. [a] -> Prop+null ([])   = true+null (x:xs) = false++measure fst :: (a,b) -> a+fst (a,b) = a++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)}++assume $         :: (x:a -> b) -> a -> b+assume id        :: x:a -> {v:a | v = x}++
+ include/GHC/Classes.spec view
@@ -0,0 +1,29 @@+module spec GHC.Classes where++import GHC.Types++not     :: x:GHC.Types.Bool -> {v:GHC.Types.Bool | (Prop(v) <=> ~Prop(x))}+(&&)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool+        -> {v:GHC.Types.Bool | (Prop(v) <=> (Prop(x) && Prop(y)))}+(||)    :: x:GHC.Types.Bool -> y:GHC.Types.Bool+        -> {v:GHC.Types.Bool | (Prop(v) <=> (Prop(x) || Prop(y)))}+(==)    :: (GHC.Classes.Eq  a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x = y)}+(/=)    :: (GHC.Classes.Eq  a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x != y)}+(>)     :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x > y)}+(>=)    :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x >= y)}+(<)     :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x < y)}+(<=)    :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Bool | (Prop(v) <=> x <= y)}++compare :: (GHC.Classes.Ord a) => x:a -> y:a+        -> {v:GHC.Types.Ordering | (((v = GHC.Types.EQ) <=> (x = y)) &&+                                    ((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) }
+ include/GHC/ForeignPtr.spec view
@@ -0,0 +1,4 @@+module spec GHC.ForeignPtr where++mallocPlainForeignPtrBytes :: n:{v:GHC.Types.Int  | v >= 0 } -> (GHC.Types.IO (ForeignPtrN a n))+
+ include/GHC/IO/Handle.spec view
@@ -0,0 +1,10 @@+module spec GHC.IO.Handle where++hGetBuf :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat+        -> (GHC.Types.IO {v:Nat | v <= n})++hGetBufNonBlocking :: GHC.IO.Handle.Handle -> GHC.Ptr.Ptr a -> n:Nat+                   -> (GHC.Types.IO {v:Nat | v <= n})++hFileSize :: GHC.IO.Handle.Handle+          -> (GHC.Types.IO {v:GHC.Integer.Type.Integer | v >= 0})
+ include/GHC/Int.spec view
@@ -0,0 +1,6 @@+module spec GHC.Int where++embed GHC.Int.Int32 as int+embed GHC.Int.Int64 as int++type Nat64 = {v:GHC.Int.Int64 | v >= 0}
+ include/GHC/List.lhs view
@@ -0,0 +1,790 @@+\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/Num.spec view
@@ -0,0 +1,9 @@+module spec GHC.Num where++GHC.Num.fromInteger :: (GHC.Num.Num a)+                    => x:GHC.Integer.Type.Integer+                    -> {v:a | v = x }++-- GHC.Num.negate :: (GHC.Num.Num a)+--                => x:a+--                -> {v:a | v = (0-x)}
+ include/GHC/Prim.spec view
@@ -0,0 +1,16 @@+module spec GHC.Prim where++embed GHC.Prim.Int#  as int+embed GHC.Prim.Addr# as int++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)}+
+ include/GHC/Ptr.spec view
@@ -0,0 +1,14 @@+module spec GHC.Ptr where++GHC.Ptr.castPtr :: p:(PtrV a) -> (PtrN b (plen p))++GHC.Ptr.plusPtr :: base:(PtrV a)+                -> off:{v:GHC.Types.Int | v <= (plen base) }+                -> {v:(PtrV b) | (((pbase v) = (pbase base)) && ((plen v) = (plen base) - off))}++GHC.Ptr.minusPtr :: q:(PtrV a)+                 -> p:{v:(PtrV b) | (((pbase v) = (pbase q)) && ((plen v) >= (plen q)))}+                 -> {v:Nat | v = (plen p) - (plen q)}++measure deref     :: GHC.Ptr.Ptr a -> a+
+ include/GHC/Real.spec view
@@ -0,0 +1,13 @@+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}+
+ include/GHC/Types.spec view
@@ -0,0 +1,23 @@+module spec GHC.Types where++-- TODO: Drop prefix below+GHC.Types.EQ :: {v:GHC.Types.Ordering | v = (cmp v) }+GHC.Types.LT :: {v:GHC.Types.Ordering | v = (cmp v) }+GHC.Types.GT :: {v:GHC.Types.Ordering | v = (cmp v) }++measure cmp :: GHC.Types.Ordering -> GHC.Types.Ordering+cmp (GHC.Types.EQ) = { v | v = GHC.Types.EQ }+cmp (GHC.Types.LT) = { v | v = GHC.Types.LT }+cmp (GHC.Types.GT) = { v | v = GHC.Types.GT }+++GHC.Types.True  :: {v:GHC.Types.Bool | (Prop(v))}+GHC.Types.False :: {v:GHC.Types.Bool | (~ (Prop(v)))}++embed GHC.Types.Double as int++++++
+ include/GHC/Word.spec view
@@ -0,0 +1,7 @@+module spec GHC.Word where++embed GHC.Word.Word   as int+embed GHC.Word.Word8  as int+embed GHC.Word.Word16 as int+embed GHC.Word.Word32 as int+embed GHC.Word.Word64 as int
+ include/KMeansHelper.hs view
@@ -0,0 +1,78 @@+module KMeansHelper where++import Prelude hiding (zipWith)+import Data.List (sort, span, minimumBy)+import Data.Function (on)+import Data.Ord (comparing)+import Language.Haskell.Liquid.Prelude (liquidAssert, liquidError)+++-- | Fixed-Length Lists++{-@ type List a N = {v : [a] | (len v) = N} @-}+++-- | N Dimensional Points++{-@ type Point N = List Double N @-}++{-@ type NonEmptyList a = {v : [a] | (len v) > 0} @-}++-- | Clustering ++{-@ type Clustering a  = [(NonEmptyList a)] @-}++------------------------------------------------------------------+-- | Grouping By a Predicate -------------------------------------+------------------------------------------------------------------++{-@ groupBy       :: (a -> a -> Bool) -> [a] -> (Clustering a) @-}+groupBy _  []     =  []+groupBy eq (x:xs) =  (x:ys) : groupBy eq zs+  where (ys,zs)   = span (eq x) xs++------------------------------------------------------------------+-- | Partitioning By a Size --------------------------------------+------------------------------------------------------------------++{-@ type PosInt = {v: Int | v > 0 } @-}++{-@ partition           :: size:PosInt -> [a] -> (Clustering a) @-}++partition size []       = []+partition size ys@(_:_) = zs : partition size zs'+  where+    zs                  = take size ys+    zs'                 = drop size ys++-----------------------------------------------------------------------+-- | Safe Zipping -----------------------------------------------------+-----------------------------------------------------------------------++{-@ zipWith :: (a -> b -> c) -> xs:[a] -> (List b (len xs)) -> (List c (len xs)) @-}+zipWith f (a:as) (b:bs) = f a b : zipWith f as bs+zipWith _ [] []         = []++-- Other cases only for exposition+zipWith _ (_:_) []      = liquidError "Dead Code"+zipWith _ [] (_:_)      = liquidError "Dead Code"++-----------------------------------------------------------------------+-- | "Matrix" Transposition -------------------------------------------+-----------------------------------------------------------------------++{-@ type Matrix a Rows Cols  = (List (List a Cols) Rows) @-}++{-@ transpose                :: c:Int -> r:PosInt -> Matrix a r c -> Matrix a c r @-}++transpose                    :: Int -> Int -> [[a]] -> [[a]]+transpose 0 _ _              = []+transpose c r ((x:xs) : xss) = (x : map head xss) : transpose (c-1) r (xs : map tail xss)++-- Or, with comprehensions+-- transpose c r ((x:xs):xss) = (x : [ xs' | (x':_) <- xss ]) : transpose (c-1) r (xs : [xs' | (_ : xs') <- xss])++-- Not needed, just for exposition+transpose c r ([] : _)       = liquidError "dead code"+transpose c r []             = liquidError "dead code"+
+ include/Language/Haskell/Liquid/List.hs view
@@ -0,0 +1,11 @@+module Language.Haskell.Liquid.List (transpose) where++import Data.List hiding (transpose)++{-# ANN transpose "forall a. n:Int -> xs:[{v:[a]|len(v) = n}] -> {v:[[a]] | len(v) = n}" #-}+transpose                  :: Int -> [[a]] -> [[a]]+transpose n []             = []+transpose n ([]   : xss)   = transpose n xss+transpose n ((x:xs) : xss) = (x : [h | (h:_) <- xss]) : transpose (n - 1) (xs : [ t | (_:t) <- xss])++
+ include/Language/Haskell/Liquid/Prelude.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE MagicHash #-}++{- OPTIONS_GHC -cpp #-}+{- OPTIONS_GHC -cpp -fglasgow-exts -}++module Language.Haskell.Liquid.Prelude where++import Foreign.C.Types          (CSize(..))+import Foreign.Ptr+import Foreign.ForeignPtr+import GHC.Base++-------------------------------------------------------------------+--------------------------- Arithmetic ----------------------------+-------------------------------------------------------------------++{-@ assume plus   :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x + y}  @-}+{-@ assume minus  :: x:{v:Int | true } -> y:{v:Int | true} -> {v:Int | v = x - y} @-}+{-@ assume times  :: x:Int -> y:Int -> Int                           @-}+{-@ assume eq     :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x = y)}  @-}+{-@ assume neq    :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x != y)} @-}+{-@ assume leq    :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x <= y)} @-}+{-@ assume geq    :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x >= y)} @-}+{-@ assume lt     :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x < y)}  @-}+{-@ assume gt     :: x:Int -> y:Int -> {v:Bool | ((Prop v) <=> x > y)}  @-}++{-# NOINLINE plus #-}+plus :: Int -> Int -> Int+plus x y = x + y++{-# NOINLINE minus #-}+minus :: Int -> Int -> Int+minus x y = x - y++{-# NOINLINE times #-}+times :: Int -> Int -> Int+times x y = x * y++-------------------------------------------------------------------+--------------------------- Comparisons ---------------------------+-------------------------------------------------------------------++{-# NOINLINE eq #-}+eq :: Int -> Int -> Bool+eq x y = x == y++{-# NOINLINE neq #-}+neq :: Int -> Int -> Bool+neq x y = not (x == y)++{-# NOINLINE leq #-}+leq :: Int -> Int -> Bool+leq x y = x <= y++{-# NOINLINE geq #-}+geq :: Int -> Int -> Bool+geq x y = x >= y++{-# NOINLINE lt #-}+lt :: Int -> Int -> Bool+lt x y = x < y++{-# NOINLINE gt #-}+gt :: Int -> Int -> Bool+gt x y = x > y++-------------------------------------------------------------------+------------------------ Specifications ---------------------------+-------------------------------------------------------------------++{-@ assume liquidAssertB :: x:{v:Bool | (Prop v)} -> {v: Bool | (Prop v)} @-}+{-# NOINLINE liquidAssertB #-}+liquidAssertB :: Bool -> Bool+liquidAssertB b = b++{-@ assume liquidAssert :: {v:Bool | (Prop v)} -> a -> a  @-}+{-# NOINLINE liquidAssert #-}+liquidAssert :: Bool -> a -> a +liquidAssert b x = x++{-@ assume liquidAssume :: b:Bool -> a -> {v: a | (Prop b)}  @-}+{-# NOINLINE liquidAssume #-}+liquidAssume :: Bool -> a -> a +liquidAssume b x = x++++{-@ assume liquidError :: {v: String | 0 = 1} -> a  @-}+{-# NOINLINE liquidError #-}+liquidError :: String -> a+liquidError = error ++{-@ assume crash  :: forall a . x:{v:Bool | (Prop v)} -> a @-}+{-# NOINLINE crash #-}+crash :: Bool -> a +crash b = undefined ++{-# NOINLINE force #-}+force x = True ++{-# NOINLINE choose #-}+choose :: Int -> Int+choose x = undefined ++-------------------------------------------------------------------+----------- Modular Arithmetic Wrappers ---------------------------+-------------------------------------------------------------------++-- tedium because fixpoint doesnt want to deal with (x mod y) only (x mod c)+{-@ assume isEven :: x:Int -> {v:Bool | ((Prop v) <=> ((x mod 2) = 0))} @-}+{-# NOINLINE isEven #-}+isEven   :: Int -> Bool+isEven x = x `mod` 2 == 0++{-@ assume isOdd :: x:Int -> {v:Bool | ((Prop v) <=> ((x mod 2) = 1))} @-}+{-# NOINLINE isOdd #-}+isOdd   :: Int -> Bool+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]+safeZipWith f (a:as) (b:bs) = f a b : safeZipWith f as bs+
+ include/Language/Haskell/Liquid/Prelude.pred view
@@ -0,0 +1,22 @@+assume (>) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool+assume (<) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool+assume (>=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool+assume (<=) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool+assume (==) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> Bool+assume (+) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True+assume (*) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True+assume (-) :: forall a. forAll p1:a p2:a. (Ord a^True) => a^p1 -> a^p2 -> a^True+assume ($) :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> a^q1 -> b^q2+assume (.) :: forall b c a. forAll q1:a q2:b q3:c. (b^q2 -> c^q3) -> (a^q1 -> b^q2) -> a^q1 -> c^q3+assume filter :: forall a. forAll p1:a. (a^p1 -> Bool) -> [a^p1]-> [a^p1]+assume snd :: forall a b. forAll p1:a p2:b. (a^p1, b^p2)-> b^p2+assume map :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2) -> [a^q1]-> [b^q2]+assume (++) :: forall a. forAll q:a. [a^q]-> [a^q]-> [a^q]+assume concat :: forall a. forAll q:a. [[a^q]]-> [a^q]+assume foldl :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> a^q1) -> a^q1 -> [b^q2]-> a^q1+assume foldr :: forall a b. forAll q1:a q2:b. (a^q1 -> b^q2 -> b^q2) -> b^q2 -> [a^q1]-> b^q2+assume (,) :: forall a b. forAll q1:a q2:b. a^q1 -> b^q2 ->(a^q1, b^q2)+assume Prelude.error :: forall a. forAll q2:a. [Char]-> a^q2+assume Prelude.head :: forall a. forAll q:a. [a^q]-> a^q+assume Prelude.tail :: forall a. forAll q:a. [a^q]-> [a^q]+assume Prelude.enumFromTo :: forall a. forAll q:a. (Enum a^ True) => a^q -> a^q -> [a^q]
+ include/PatErr.spec view
@@ -0,0 +1,7 @@+module spec Prelude where++assume Control.Exception.Base.patError :: {v:GHC.Prim.Addr# | false } -> a+assume Control.Exception.Base.irrefutPatError :: {v:GHC.Prim.Addr# | false} -> a+assume Control.Exception.Base.recSelError :: {v:GHC.Prim.Addr# | false} -> a+assume Control.Exception.Base.nonExhaustiveGuardsError :: {v:GHC.Prim.Addr# | false} -> a+assume Control.Exception.Base.noMethodBindingError :: {v:GHC.Prim.Addr# | false} -> a
+ include/Prelude.hquals view
@@ -0,0 +1,23 @@+//BOT: Do not delete EVER!++qualif Bot(v:@(0))    : 0 = 1 +qualif Bot(v:obj)     : 0 = 1 +qualif Bot(v:a)       : 0 = 1 +qualif Bot(v:bool)    : 0 = 1 +qualif Bot(v:int)     : 0 = 1 +qualif CmpZ(v:a)      : v [ < ; <= ; > ; >= ; = ; != ] 0+qualif Cmp(v:a,~A:a)  : v [ < ; <= ; > ; >= ; = ; != ] ~A+qualif One(v:int)     : v = 1+qualif True(v:bool)   : (? v) +qualif False(v:bool)  : ~ (? v) +qualif True1(v:GHC.Types.Bool)   : Prop(v)+qualif False1(v:GHC.Types.Bool)  : ~ Prop(v)+++qualif Papp(v:a,~P:Pred a) : papp1(~P, v)+constant papp1 : func(2, [Pred @(0); @(1); 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])++constant Prop : func(0, [GHC.Types.Bool; bool])
+ include/Prelude.spec view
@@ -0,0 +1,35 @@+module spec Prelude where++import GHC.Base+import GHC.Int+import GHC.List+import GHC.Num+import GHC.Real+import GHC.Word++import Data.Maybe++assume GHC.Base..               :: forall< p :: xx:b -> c -> Prop+                                         , q :: yy:a -> b -> Prop>.+                                      f:(x:b -> c<p x>) ->+                                      g:(y:a -> b<q y>) ->+                                      x:a ->+                                      exists[z:b<q x>].c<p z>+assume GHC.Integer.smallInteger :: x:GHC.Prim.Int#+                                -> { v:GHC.Integer.Type.Integer |+                                     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.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 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))++type IncrListD a D = [a]<{\x y -> (x+D) <= y}>
+ include/System/IO.spec view
@@ -0,0 +1,3 @@+module spec System.IO where++import GHC.IO.Handle
+ include/len.hquals view
@@ -0,0 +1,5 @@++//Qualifiers about complex length relationships++qualif LenSum(v:[a], ~A:[b], ~B:[c]): len([v]) = (len([~A]) [ +; - ] len([~B]))+
+ liquidhaskell.cabal view
@@ -0,0 +1,140 @@+Name:                liquidhaskell+Version:             0.1+Copyright:           2010-13 Ranjit Jhala, University of California, San Diego.+build-type:          Simple+Synopsis:            Liquid Types for Haskell +Description:         Liquid Types for Haskell.+Homepage:            http://goto.ucsd.edu/liquidhaskell+License:             GPL+License-file:        LICENSE+Author:              Ranjit Jhala+Maintainer:          Ranjit Jhala <jhala@cs.ucsd.edu>+Category:            Language+Build-Type:          Simple+Cabal-version:       >=1.8++data-files: include/*.hquals+          , include/*.hs+          , include/*.spec+          , include/Control/*.spec+          , include/Data/*.hquals+          , include/Data/*.spec+          , include/Data/Text/*.spec+          , include/Data/Text/Fusion/*.spec+          , include/Data/Text/Lazy/*.spec+          , 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/System/*.spec+          , syntax/liquid.css++Executable liquid +  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<1.2+               , unordered-containers+               , aeson+               , bytestring+               -- , liquidtypes++  Main-is: Liquid.hs+  --ghc-options: -O -W+  Extensions: PatternGuards++Library+   Build-Depends: base+                , 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+                , hashable<1.2+                , unordered-containers+                , liquid-fixpoint+                , aeson+                , bytestring+ +   hs-source-dirs:  include, .+ +   Exposed-Modules: Language.Haskell.Liquid.Prelude,+                    Language.Haskell.Liquid.List, +                    Language.Haskell.Liquid.PrettyPrint, +                    Language.Haskell.Liquid.Bare,+                    Language.Haskell.Liquid.Constraint, +                    Language.Haskell.Liquid.Measure, +                    Language.Haskell.Liquid.Parse, +                    Language.Haskell.Liquid.GhcInterface, +                    Language.Haskell.Liquid.RefType, +                    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.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.Desugar.DsExpr,+                    Language.Haskell.Liquid.Desugar.DsListComp,+                    Language.Haskell.Liquid.Desugar.MatchCon,+                    Language.Haskell.Liquid.Desugar.MatchLit,+                    Language.Haskell.Liquid.Desugar.DsArrows,+                    Language.Haskell.Liquid.Desugar.DsUtils,+                    Language.Haskell.Liquid.Desugar.Match,+                    Language.Haskell.Liquid.Desugar.DsBinds,+                    Language.Haskell.Liquid.Desugar.DsGRHSs,+                    Language.Haskell.Liquid.Desugar.HscMain+   --ghc-options: -O -W+   Extensions: PatternGuards++
+ syntax/liquid.css view
@@ -0,0 +1,105 @@+.hs-linenum {+  color: #B2B2B2; +  font-style: italic;+}++.hs-error {+  background-color: #FF8585 ;+}++.hs-keyglyph {+  color: #007020+}++.hs-keyword {+  color: #007020;+  // font-weight: bold;+}++.hs-comment, .hs-comment a {color: green;}++.hs-str, .hs-chr {color: teal;}++.hs-conid { +  color: #902000;   /* color: #00FFFF; color: #0E84B5; */+  //font-weight: bold;  +}++.hs-definition { +  color: #06287E +  /* font-weight: bold; */ +}++.hs-varid, .hs-varop, .hs-layout {+  color: black; +}++.hs-num {+  color: #40A070;+}++.hs-conop {+  color: #902000; +}++.hs-cpp {+  color: orange;+}++.hs-sel  {}++a.annot {+  position:relative; +  color:#000;+  text-decoration:none; +  white-space: pre; +}++a.annot:hover { +  z-index:25; +  background-color: #D8D8D8;+}++a.annot span.annottext{display: none}++a.annot:hover span.annottext{ +  +  border-radius: 5px 5px;+  +  -moz-border-radius: 5px; +  -webkit-border-radius: 5px; +  +  box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); +  -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1);+  -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); ++  white-space:pre;+  display:block;+  position: absolute; +  left: 1em; top: 2em; +  z-index: 99;+  margin-left: 5; +  background: #FFFFAA; +  border: 3px solid #FFAD33;+  padding: 0.8em 1em;+}++code {+   /* font-weight: bold; */+   background-color: rgb(250, 250, 250); +   border: 1px solid rgb(200, 200, 200);+   padding-left: 4px;+   padding-right: 4px;+}++pre {+  background-color: #f0f0f0;+  border-top: 1px solid #ccc;+  border-bottom: 1px solid #ccc;+  padding: 5px;+  // font-size: 120%;+  // font-family: Bitstream Vera Sans Mono,monospace;+  display: block;+  overflow: visible;+}+