Skip to content

Commit fa5270b

Browse files
nikivazounikivazou
authored
Merge pull request #1623 from pbougou/synthesis
Add basic Synthesis Support
2 parents 6c3a5b4 + 33e24bd commit fa5270b

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

68 files changed

+2985
-50
lines changed

‎.ghci

+1
Original file line numberDiff line numberDiff line change
@@ -1 +1,2 @@
11
:set -isrc
2+
:set prompt "\ESC[34mλ> \ESC[m"

‎.gitignore

+2
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,8 @@ cabal.sandbox.config
3636
.ghc.environment.*
3737
cabal.project.local
3838

39+
tests/synthesis/logs/*
40+
!tests/synthesis/logs/.gitkeep
3941
/tests/logs/
4042
/.stack-work/
4143
/.vagrant/

‎README.md

+49-1
Original file line numberDiff line numberDiff line change
@@ -1294,7 +1294,7 @@ attaches a refinement to a datatype globally.
12941294
Do not use this mechanism -- it is *unsound* and about to
12951295
deprecated in favor of something that is [actually sound](https://github.com/ucsd-progsys/liquidhaskell/issues/126)
12961296

1297-
Forexample, the length of a list cannot be negative
1297+
For example, the length of a list cannot be negative
12981298

12991299
{-@ invariant {v:[a] | (len v >= 0)} @-}
13001300

@@ -1449,6 +1449,54 @@ the specifications you write i.e.
14491449
2. measure bodies and,
14501450
3. data constructor definitions.
14511451

1452+
Basic support for program synthesis
1453+
===================================
1454+
1455+
How to use it
1456+
-------------
1457+
1458+
Activate the flag for typed holes in LiquidHaskell. E.g.
1459+
from command line:
1460+
1461+
liquid --typedholes
1462+
1463+
In a Haskell source file:
1464+
1465+
{-@ LIQUID --typed-holes @-}
1466+
1467+
Using the flag for typed holes, two more flags can be used:
1468+
1469+
- **max-match-depth**: Maximum number of pattern match expressions used during synthesis (default value: 4).
1470+
1471+
- **max-app-depth**: Maximum number of same function applications used during synthesis (default value: 2).
1472+
1473+
Having the program specified in a Haskell source file, use
1474+
GHC' s hole variables, e.g.:
1475+
1476+
{-@ myMap :: (a -> b) -> xs:[a] -> {v:[b] | len v == len xs} @-}
1477+
myMap :: (a -> b) -> [a] -> [b]
1478+
myMap = _goal
1479+
1480+
Current limitations
1481+
-------------------
1482+
1483+
This is an experimental feature, so potential users could only
1484+
expect to synthesize programs, like [these](https://github.com/ucsd-progsys/liquidhaskell/tree/develop/tests/synth).
1485+
1486+
Current limitations include:
1487+
1488+
- No boolean conditionals are synthesized.
1489+
- Holes can only appear at top level, e.g.:
1490+
1491+
{-@ f :: x: [a] -> { v: [a] | v == x } @-}
1492+
f :: [a] -> [a]
1493+
-- This works
1494+
f = _hole
1495+
-- This does not work
1496+
f x = _hole
1497+
1498+
- Only one hole can appear in each module.
1499+
14521500

14531501
Generating HTML Output
14541502
======================

‎include/Language/Haskell/Liquid/Synthesize/Error.hs

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module Language.Haskell.Liquid.Synthesize.Error where
2+
3+
{-@ err :: { v: Int | false } -> a @-}
4+
err :: Int -> a
5+
err s = undefined

‎liquidhaskell.cabal

+31-1
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ data-files: include/*.hquals
4141
include/GHC/*.spec
4242
include/GHC/IO/*.spec
4343
include/Language/Haskell/Liquid/*.hs
44+
include/Language/Haskell/Liquid/Synthesize/*.hs
4445
include/Language/Haskell/Liquid/*.pred
4546
include/System/*.spec
4647
include/710/Data/*.spec
@@ -120,6 +121,13 @@ library
120121
Language.Haskell.Liquid.Parse
121122
Language.Haskell.Liquid.Prelude
122123
Language.Haskell.Liquid.ProofCombinators
124+
Language.Haskell.Liquid.Synthesize.GHC
125+
Language.Haskell.Liquid.Synthesize.Termination
126+
Language.Haskell.Liquid.Synthesize.Monad
127+
Language.Haskell.Liquid.Synthesize.Misc
128+
Language.Haskell.Liquid.Synthesize.Generate
129+
Language.Haskell.Liquid.Synthesize.Check
130+
Language.Haskell.Liquid.Synthesize.Env
123131
Language.Haskell.Liquid.Termination.Structural
124132
Language.Haskell.Liquid.Transforms.ANF
125133
Language.Haskell.Liquid.Transforms.CoreToLogic
@@ -144,6 +152,7 @@ library
144152
Language.Haskell.Liquid.Types.Types
145153
Language.Haskell.Liquid.Types.Variance
146154
Language.Haskell.Liquid.Types.Visitors
155+
Language.Haskell.Liquid.Synthesize
147156
Language.Haskell.Liquid.UX.ACSS
148157
Language.Haskell.Liquid.UX.Annotate
149158
Language.Haskell.Liquid.UX.CTags
@@ -184,6 +193,7 @@ library
184193
, githash
185194
, parsec >= 3.1
186195
, pretty >= 1.1
196+
, split
187197
, syb >= 0.4.4
188198
, template-haskell >= 2.9
189199
, temporary >= 1.2
@@ -193,8 +203,9 @@ library
193203
, transformers >= 0.3
194204
, unordered-containers >= 0.2
195205
, vector >= 0.10
206+
, extra
196207
default-language: Haskell98
197-
default-extensions: PatternGuards
208+
default-extensions: PatternGuards, RecordWildCards, DoAndIfThenElse
198209
ghc-options: -W -fwarn-missing-signatures
199210

200211
if flag(include)
@@ -273,3 +284,22 @@ test-suite liquidhaskell-parser
273284
, tasty-hunit >= 0.9
274285
default-language: Haskell2010
275286
ghc-options: -W
287+
288+
test-suite synthesis
289+
type: exitcode-stdio-1.0
290+
main-is: Synthesis.hs
291+
other-modules: Paths_liquidhaskell
292+
hs-source-dirs: tests
293+
build-depends: base >= 4.8.1.0 && < 5
294+
, liquid-fixpoint >= 0.8.0.0
295+
, liquidhaskell
296+
, tasty >= 0.7
297+
, tasty-hunit
298+
, process
299+
, filepath
300+
, text
301+
, directory
302+
, ghc
303+
, extra
304+
default-language: Haskell2010
305+
ghc-options: -W

‎src/Language/Haskell/Liquid/Constraint/Generate.hs

+20-9
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@
1818
-- | This module defines the representation of Subtyping and WF Constraints,
1919
-- and the code for syntax-directed constraint generation.
2020

21-
module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints ) where
21+
module Language.Haskell.Liquid.Constraint.Generate ( generateConstraints, generateConstraintsWithEnv, caseEnv, consE ) where
2222

2323
import Outputable (Outputable)
2424
import Prelude hiding (error)
@@ -76,6 +76,7 @@ import Language.Haskell.Liquid.Transforms.CoreToLogic (weakenResult)
7676
import Language.Haskell.Liquid.Bare.DataType (makeDataConChecker)
7777

7878
import Language.Haskell.Liquid.Types hiding (binds, Loc, loc, Def)
79+
import Debug.Trace
7980

8081
--------------------------------------------------------------------------------
8182
-- | Constraint Generation: Toplevel -------------------------------------------
@@ -84,12 +85,18 @@ generateConstraints :: TargetInfo -> CGInfo
8485
--------------------------------------------------------------------------------
8586
generateConstraints info = {-# SCC "ConsGen" #-} execState act $ initCGI cfg info
8687
where
87-
act = consAct cfg info
88+
act = do { γ <- initEnv info; consAct γ cfg info }
8889
cfg = getConfig info
8990

90-
consAct :: Config -> TargetInfo -> CG ()
91-
consAct cfg info = do
92-
γ <- initEnv info
91+
generateConstraintsWithEnv :: TargetInfo -> CGInfo -> CGEnv -> CGInfo
92+
--------------------------------------------------------------------------------
93+
generateConstraintsWithEnv info cgi γ = {-# SCC "ConsGenEnv" #-} execState act cgi
94+
where
95+
act = consAct γ cfg info
96+
cfg = getConfig info
97+
98+
consAct :: CGEnv -> Config -> TargetInfo -> CG ()
99+
consAct γ cfg info = do
93100
let sSpc = gsSig . giSpec $ info
94101
let gSrc = giSrc info
95102
when (gradual cfg) (mapM_ (addW . WfC γ . val . snd) (gsTySigs sSpc ++ gsAsmSigs sSpc))
@@ -191,10 +198,11 @@ makeRecType :: (Enum a1, Eq a1, Num a1, F.Symbolic a)
191198
makeRecType autoenv t vs dxs is
192199
= mergecondition t $ fromRTypeRep $ trep {ty_binds = xs', ty_args = ts'}
193200
where
194-
(xs', ts') = unzip $ replaceN (last is) (makeDecrType autoenv vdxs) xts
201+
(xs', ts') = unzip $ replaceN (last is) (fromLeft $ makeDecrType autoenv vdxs) xts
195202
vdxs = zip vs dxs
196203
xts = zip (ty_binds trep) (ty_args trep)
197204
trep = toRTypeRep $ unOCons t
205+
fromLeft (Left x) = x
198206

199207
unOCons :: RType c tv r -> RType c tv r
200208
unOCons (RAllT v t r) = RAllT v (unOCons t) r
@@ -425,6 +433,9 @@ consCB _ _ γ (NonRec x _) | isDictionary x
425433
isDictionary = isJust . dlookup (denv γ)
426434

427435

436+
consCB _ _ γ (NonRec x _ ) | isHoleVar x && typedHoles (getConfig γ)
437+
= return γ
438+
428439
consCB _ _ γ (NonRec x def)
429440
| Just (w, τ) <- grepDictionary def
430441
, Just d <- dlookup (denv γ) w
@@ -673,9 +684,9 @@ cconsE' γ (Var x) t | isHoleVar x && typedHoles (getConfig γ)
673684
= addHole x t γ
674685

675686
cconsE' γ e t
676-
= do te <- consE γ e
677-
te' <- instantiatePreds γ e te >>= addPost γ
678-
addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e)
687+
= do te <- consE γ e
688+
te' <- instantiatePreds γ e te >>= addPost γ
689+
addC (SubC γ te' t) ("cconsE: " ++ "\n t = " ++ showpp t ++ "\n te = " ++ showpp te ++ GM.showPpr e)
679690

680691
lambdaSingleton :: CGEnv -> F.TCEmb TyCon -> Var -> CoreExpr -> UReft F.Reft
681692
lambdaSingleton γ tce x e

‎src/Language/Haskell/Liquid/Constraint/Monad.hs

+9-5
Original file line numberDiff line numberDiff line change
@@ -29,6 +29,7 @@ import Language.Fixpoint.Misc hiding (errorstar)
2929
import Language.Haskell.Liquid.GHC.Misc -- (concatMapM)
3030
import Language.Haskell.Liquid.GHC.SpanStack (srcSpan)
3131
import qualified Language.Haskell.Liquid.GHC.API as Ghc
32+
import qualified Language.Fixpoint.Types as F
3233

3334
--------------------------------------------------------------------------------
3435
-- | `addC` adds a subtyping constraint into the global pool.
@@ -102,14 +103,17 @@ addLocA !xo !l !t
102103
-- | Used for annotating holes
103104

104105
addHole :: Var -> SpecType -> CGEnv -> CG ()
105-
addHole x t γ = do
106-
modify $ \s -> s {holesMap = M.insertWith (<>) x hinfo $ holesMap s}
107-
addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t
106+
addHole x t γ
107+
| typedHoles (getConfig γ) =
108+
do st <- get
109+
modify $ \s -> s {holesMap = M.insert x (hinfo (st, γ)) $ holesMap s}
110+
-- addWarning $ ErrHole loc ("hole found") (reGlobal env <> reLocal env) x' t
111+
| otherwise = return ()
108112
where
109-
hinfo = [HoleInfo t loc env]
113+
hinfo = HoleInfo t loc env
110114
loc = srcSpan $ cgLoc γ
111115
env = mconcat [renv γ, grtys γ, assms γ, intys γ]
112-
x' = text $ showSDoc $ Ghc.pprNameUnqualified $ Ghc.getName x
116+
x' = F.symbol x -- text $ showSDoc $ Ghc.pprNameUnqualified $ Ghc.getName x
113117

114118
--------------------------------------------------------------------------------
115119
-- | Update annotations for a location, due to (ghost) predicate applications

‎src/Language/Haskell/Liquid/Constraint/Types.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -181,7 +181,7 @@ data CGInfo = CGInfo
181181
, binds :: !F.BindEnv -- ^ set of environment binders
182182
, ebinds :: ![F.BindId] -- ^ existentials
183183
, annotMap :: !(AnnInfo (Annot SpecType)) -- ^ source-position annotation map
184-
, holesMap :: !(M.HashMap Var [HoleInfo SpecType]) -- ^ information for ghc hole expressions
184+
, holesMap :: !(M.HashMap Var (HoleInfo (CGInfo, CGEnv) SpecType)) -- ^ information for ghc hole expressions
185185
, tyConInfo :: !TyConMap -- ^ information about type-constructors
186186
, specDecr :: ![(Var, [Int])] -- ^ ^ Lexicographic order of decreasing args (DEPRECATED)
187187
, newTyEnv :: !(M.HashMap TC.TyCon SpecType) -- ^ Mapping of new type type constructors with their refined types.

‎src/Language/Haskell/Liquid/Liquid.hs

+13-7
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# LANGUAGE NamedFieldPuns #-}
22
{-# LANGUAGE TupleSections #-}
33
{-# LANGUAGE ScopedTypeVariables #-}
4+
{-# LANGUAGE RecordWildCards #-}
45

56
{-@ LIQUID "--diff" @-}
67

@@ -37,6 +38,8 @@ import Language.Haskell.Liquid.Misc
3738
import Language.Fixpoint.Misc
3839
import Language.Fixpoint.Solver
3940
import qualified Language.Fixpoint.Types as F
41+
import Language.Haskell.Liquid.Types
42+
import Language.Haskell.Liquid.Synthesize (synthesize)
4043
import Language.Haskell.Liquid.Types.RefType (applySolution)
4144
import Language.Haskell.Liquid.UX.Errors
4245
import Language.Haskell.Liquid.UX.CmdLine
@@ -221,7 +224,6 @@ updTargetInfoTermVars i = updInfo i (ST.terminationVars i)
221224
updSpec sp vs = sp { gsTerm = updSpTerm (gsTerm sp) vs }
222225
updSpTerm gsT vs = gsT { gsNonStTerm = S.fromList vs }
223226

224-
225227
dumpCs :: CGInfo -> IO ()
226228
dumpCs cgi = do
227229
putStrLn "***************************** SubCs *******************************"
@@ -234,25 +236,29 @@ dumpCs cgi = do
234236
pprintMany :: (PPrint a) => [a] -> Doc
235237
pprintMany xs = vcat [ F.pprint x $+$ text " " | x <- xs ]
236238

237-
instance Show Cinfo where
238-
show = show . F.toFix
239-
240239
solveCs :: Config -> FilePath -> CGInfo -> TargetInfo -> Maybe [String] -> IO (Output Doc)
241240
solveCs cfg tgt cgi info names = do
242241
finfo <- cgInfoFInfo info cgi
243-
F.Result r0 sol _ <- solve (fixConfig tgt cfg) finfo
242+
let fcfg = fixConfig tgt cfg
243+
F.Result r0 sol _ <- solve fcfg finfo
244244
let failBs = gsFail $ gsTerm $ giSpec info
245245
let (r,rf) = splitFails (S.map val failBs) r0
246246
let resErr = applySolution sol . cinfoError . snd <$> r
247247
-- resModel_ <- fmap (e2u cfg sol) <$> getModels info cfg resErr
248248
let resModel_ = e2u cfg sol <$> resErr
249-
let resModel = resModel_ `addErrors` (e2u cfg sol <$> logErrors cgi)
249+
let resModel' = resModel_ `addErrors` (e2u cfg sol <$> logErrors cgi)
250250
`addErrors` makeFailErrors (S.toList failBs) rf
251-
`addErrors` makeFailUseErrors (S.toList failBs) (giCbs $ giSrc info)
251+
`addErrors` makeFailUseErrors (S.toList failBs) (giCbs $ giSrc info)
252+
let lErrors = applySolution sol <$> logErrors cgi
253+
hErrors <- if (typedHoles cfg)
254+
then synthesize tgt fcfg (cgi{holesMap = applySolution sol <$> holesMap cgi})
255+
else return []
256+
let resModel = resModel' `addErrors` (e2u cfg sol <$> (lErrors ++ hErrors))
252257
let out0 = mkOutput cfg resModel sol (annotMap cgi)
253258
return $ out0 { o_vars = names }
254259
{ o_result = resModel }
255260

261+
256262
e2u :: Config -> F.FixSolution -> Error -> UserError
257263
e2u cfg s = fmap F.pprint . tidyError cfg s
258264

0 commit comments

Comments
 (0)