Skip to content
Permalink
Browse files

Merge PR #167: Ran the update of the code formatter

  • Loading branch information
mariari authored and cwgoes committed Nov 9, 2019
1 parent 2b14f06 commit d1bd6f66a5ab0b92f4cff7a704c15f9a998d364b
@@ -92,8 +92,11 @@ transformAndEvaluateErasedCore debug term = do
net = INet.astToNet ast INet.defaultEnv
when debug $ H.outputStrLn ("Translated to net: " <> show net)
let reduced = Graph.runFlipNet (INet.reduceAll 1000000) net

info = Env.info reduced

res = Env.net reduced

when debug $ H.outputStrLn ("Reduced net: " <> show res)
let readback = INet.netToAst res
when debug $ H.outputStrLn ("Reduction info: " <> show info)
@@ -87,9 +87,13 @@ typeOf (App t1 t2) = do
f p = do
(ArrowType (_ Proxy k), ArrowType (_ Proxy to)) pure (isFromA p)
let ta = R.typeRep R.TypeRep k

tb = R.typeRep R.TypeRep Int

tc = R.typeRep R.TypeRep to

td = R.typeRep Arrowable to R.TypeRep to

case (R.eqTypeRep ta tb) of
Nothing [False, False]
Just T.HRefl
@@ -103,8 +103,11 @@ addBlock bname = do
ix get @"blockCount"
nms get @"names"
let new = emptyBlock ix

(qname, supply) = uniqueName bname nms

name = internName qname

put @"blocks" (Map.insert name new bls)
put @"blockCount" (succ ix)
put @"names" supply
@@ -254,6 +254,7 @@ intOfNumPorts typ numPort cont = do
generateIf typ tag smallBranch largeBranch
where
smallBranch = branchGen numPortsSmall numPortsSmallValue return

largeBranch = branchGen numPortsLarge numPortsLargeValuePtr $
\vPtr do
deref2 Block.getElementPtr $
@@ -263,6 +264,7 @@ intOfNumPorts typ numPort cont = do
Types.indincies' = Block.constant32List [0, 1]
}
load numPortsLargeValue deref2

-- Generic logic
branchGen variant variantType extraDeref = do
casted bitCast numPort (varientToType variant)
@@ -99,10 +99,14 @@ insertSums ∷
insertSums sumName variants symTbl varTbl typTbl = (newSymTbl, newVarTbl, newTypTbl)
where
sum' = createSum variants

tag' = tagSizeIntExn (tagSize variants)

typTbl' = Map.insert sumName sum' typTbl

symTbl' =
Map.insert sumName (LocalReference sum' (mkName (unintern sumName))) symTbl

newVarTbl =
fst $
foldr
@@ -121,13 +125,15 @@ insertSums sumName variants symTbl varTbl typTbl = (newSymTbl, newVarTbl, newTyp
)
(varTbl, 0)
variants

newTypTbl =
foldr
( \(Variant _s n t) tbl
Map.insert (createVariantName sumName n) t tbl
)
typTbl'
variants

newSymTbl =
foldr
( \(Variant _s n t) tbl
@@ -12,6 +12,7 @@ import qualified Z3.Monad as Z3
runMultipleConstraints a. Int [Constraint] RPT a IO ()
runMultipleConstraints numRepeat constraints syntax = do
let numset = grabTermNumbers syntax mempty

recGen _ _ _ 0 = pure ()
recGen constraintCall printModel consZ3 num = do
(r, v, s) Z3.evalZ3 constraintCall
@@ -21,27 +22,32 @@ runMultipleConstraints numRepeat constraints syntax = do
case s of
Just x
let bounds = filter (\(i, _) Set.member i numset) (zip [0 ..] x)

newCons =
bounds
>>| ( \(i, x)
Constraint
[ConstraintVar 1 i]
(Eq (fromInteger x))
)

extraConstraint =
makeVarMap newCons
>>= flip constraintsToZ3 newCons
>>= Z3.mkNot

in recNext
extraConstraint
consZ3
(pred num)
Nothing pure ()

recFirst =
recGen
(constraintSystem constraints)
putStrLn
(pure [])

recNext extra consZ3 =
recGen
( do
@@ -51,6 +57,7 @@ runMultipleConstraints numRepeat constraints syntax = do
)
(\_ pure ())
((:) <$> extra <*> consZ3)

recFirst numRepeat
where
-- Could use a list, since this should be ascending, but I do not assume that
@@ -37,6 +37,7 @@ generateParser ∷
generateParser parameterisation =
let opNames [String]
opNames = baseReservedOpNames <> reservedOpNames parameterisation

languageDef GenLanguageDef String u Identity
languageDef =
emptyDef
@@ -49,64 +50,84 @@ generateParser parameterisation =
baseReservedNames <> reservedNames parameterisation,
Token.reservedOpNames = opNames
}

ops [[Operator Char () (Elim primTy primVal)]]
ops = [[Infix appl AssocLeft]]

appl
Parser (Elim primTy primVal Elim primTy primVal Elim primTy primVal)
appl = do
whiteSpace
notFollowedBy (choice (map reservedOp opNames))
pure (\f x App f (Elim x))

lexer Token.GenTokenParser String u Identity
lexer = Token.makeTokenParser languageDef

identifier Parser String
identifier = Token.identifier lexer

reserved String Parser ()
reserved = Token.reserved lexer

reservedOp String Parser ()
reservedOp = Token.reservedOp lexer

parens Parser a Parser a
parens = Token.parens lexer

natural Parser Integer
natural = Token.natural lexer

whiteSpace Parser ()
whiteSpace = Token.whiteSpace lexer

usage Parser Usage
usage = (reserved "w" >> return Omega) <|> SNat . fromInteger <$> natural

primTyTerm Parser (Term primTy primVal)
primTyTerm = PrimTy |<< parseTy parameterisation lexer

sortTerm Parser (Term primTy primVal)
sortTerm = do
reserved "*"
n natural
return $ Star (fromInteger n)

piTerm Parser (Term primTy primVal)
piTerm = do
reserved "[Π]"
pi usage
input term
func term
return $ Pi pi input func

lamTerm Parser (Term primTy primVal)
lamTerm = do
reservedOp "\\"
binder binder
reservedOp "->"
func term
return $ Lam binder func

binder Parser Symbol
binder = intern |<< identifier

term Parser (Term primTy primVal)
term = try termOnly <|> elimTerm

termOnly Parser (Term primTy primVal)
termOnly =
parens termOnly <|> primTyTerm <|> sortTerm <|> piTerm <|> lamTerm

elimTerm Parser (Term primTy primVal)
elimTerm = do
elim elim
pure (Elim elim)

primElim Parser (Elim primTy primVal)
primElim = Prim |<< parseVal parameterisation lexer

annElim Parser (Elim primTy primVal)
annElim = do
reservedOp "@"
@@ -115,19 +136,24 @@ generateParser parameterisation =
pi usage
theType term
pure (Ann pi theTerm theType)

varElim Parser (Elim primTy primVal)
varElim = Var |<< binder

elim Parser (Elim primTy primVal)
elim = buildExpressionParser ops elim'

elim' Parser (Elim primTy primVal)
elim' = try primElim <|> annElim <|> varElim <|> parens elim

parseWhole Parser a Parser a
parseWhole p = do
whiteSpace
t p
whiteSpace
eof
return t

in parseString' (parseWhole term)

parseString' Parser a String Maybe a
@@ -41,9 +41,13 @@ caseGen (Case on cases@(C c _ _ : _)) onNoArg onRec = do
pure (f idL)
Just ([], body) pure (f $ onNoArg body)
Just (args, body) pure (f (foldr Lambda body args))

recCase t accLam = lambdaFromEnv (flip onRec accLam) t

initial t = lambdaFromEnv identity t

butLastadtCon = reverse (tailSafe (reverse adtConstructors))

last initial (lastDef (error "doesn't happen") adtConstructors)
expandedCase foldrM recCase last butLastadtCon
return $ Application on expandedCase
@@ -136,7 +136,9 @@ inl =
$ Application (Value k) (Value x)
where
x = intern "x"

k = intern "k"

l = intern "l"

-- | Op of inl that has the first argument call the 2nd
@@ -149,7 +151,9 @@ inlOp =
$ Application (Value x) (Value k)
where
x = intern "x"

k = intern "k"

l = intern "l"

inr Lambda
@@ -160,7 +164,9 @@ inr =
$ Application (Value l) (Value y)
where
y = intern "y"

k = intern "k"

l = intern "l"

-- | Op of inr that has the first argument call the 2nd
@@ -173,7 +179,9 @@ inrOp =
$ Application (Value y) (Value l)
where
y = intern "y"

k = intern "k"

l = intern "l"

foldM' Lambda
@@ -19,11 +19,13 @@ adtToScott (Adt name s) = sumRec s 1 (adtLength s)
where
adtLength Single {} = 1
adtLength (Branch _ _ s) = succ (adtLength s)

sumRec (Branch s p next) posAdt lenAdt = do
adtConstructor s (sumProd p posAdt lenAdt) name
sumRec next (succ posAdt) lenAdt
sumRec (Single s p) posAdt lenAdt =
adtConstructor s (sumProd p posAdt lenAdt) name

sumProd None posAdt lengthAdt = generateLam posAdt lengthAdt identity
sumProd Term posAdt lengthAdt =
Lambda
@@ -40,6 +42,7 @@ adtToScott (Adt name s) = sumRec s 1 (adtLength s)
(\spot Lambda (intern $ "%arg" <> show spot))
(encoding prodLen)
[1 .. prodLen]

encoding prodLen = generateLam posAdt lengthAdt $
\body
foldl
@@ -52,9 +55,11 @@ adtToScott (Adt name s) = sumRec s 1 (adtLength s)
)
body
[1 .. prodLen]

lengthProd (Product p) = succ (lengthProd p)
lengthProd Term = 1
lengthProd None = 0 -- I'm skeptical this case ever happens

generateLam posAdt lengthAdt onPosAdt =
foldr
(\spot Lambda (intern $ "%genArg" <> show spot))
@@ -79,6 +84,8 @@ scottCase c = do
Value {} error "doesn't happen"
where
onNoArg = identity

onrec c accLam = (Application c accLam)

reverseApp on (Application b1 b2) = reverseApp (Application on b1) b2
reverseApp on s = Application on s
@@ -84,9 +84,13 @@ incGraphSizeStep n = do
let memoryAllocated
| n > 0 = memAlloced + n
| otherwise = memAlloced

currentGraphSize = n + currGraph

biggestGraphSize = max currentGraphSize largestGraph

sequentalSteps = succ seqStep

put @"info" Info
{ memoryAllocated,
currentGraphSize,
@@ -64,8 +64,11 @@ instance Network FlipNet where
deleteRewire oldNodesToDelete newNodes = do
Flip net get @"net"
let newNodeSet = Set.fromList newNodes

neighbors = fst <$> (oldNodesToDelete >>= lneighbors net)

conflictingNeighbors = findConflict newNodeSet neighbors

traverse_ (uncurry link) conflictingNeighbors
delNodes oldNodesToDelete

@@ -114,8 +114,11 @@ instance Network Net where
deleteRewire oldNodesToDelete newNodes = do
Net net get @"net"
let newNodeSet = Set.fromList newNodes

neighbor = neighbors oldNodesToDelete net

conflictingNeighbors = findConflict newNodeSet neighbor

traverse_ (uncurry link) conflictingNeighbors
delNodes oldNodesToDelete

@@ -128,9 +131,11 @@ deleteAllPoints ∷
deleteAllPoints n = foldr f
where
f (n, pt) = Map.adjust (\x deleteIfDiff pt (x ^. edges) x) n

deleteIfDiff pt edge
| isSame pt edge = over edges (Map.delete pt)
| otherwise = identity

isSame pt edge = case Map.lookup pt edge of
Just x | fst x == n True
_ False

0 comments on commit d1bd6f6

Please sign in to comment.
You can’t perform that action at this time.