diff options
137 files changed, 256 insertions, 4712 deletions
diff --git a/prototypes/CGExp.hs b/CGExp.hs index 5477e485..5477e485 100644 --- a/prototypes/CGExp.hs +++ b/CGExp.hs | |||
diff --git a/CoreToGLSL.hs b/CoreToGLSL.hs index 6de88452..0bd045e9 100644 --- a/CoreToGLSL.hs +++ b/CoreToGLSL.hs | |||
@@ -22,7 +22,7 @@ import Data.Foldable (Foldable) | |||
22 | import qualified Data.Foldable as F | 22 | import qualified Data.Foldable as F |
23 | 23 | ||
24 | import Pretty | 24 | import Pretty |
25 | import Type | 25 | import CGExp |
26 | import IR(Backend(..)) | 26 | import IR(Backend(..)) |
27 | 27 | ||
28 | encodeChar :: Char -> String | 28 | encodeChar :: Char -> String |
diff --git a/CoreToIR.hs b/CoreToIR.hs index 0d05413a..4debdc8b 100644 --- a/CoreToIR.hs +++ b/CoreToIR.hs | |||
@@ -20,8 +20,7 @@ import Data.Vector (Vector,(!)) | |||
20 | import qualified Data.Vector as Vector | 20 | import qualified Data.Vector as Vector |
21 | 21 | ||
22 | import Pretty | 22 | import Pretty |
23 | import qualified Type as AST | 23 | import CGExp |
24 | import Type | ||
25 | import CoreToGLSL | 24 | import CoreToGLSL |
26 | import qualified IR as IR | 25 | import qualified IR as IR |
27 | import qualified Linear as IR | 26 | import qualified Linear as IR |
@@ -34,11 +34,9 @@ import System.FilePath | |||
34 | import Debug.Trace | 34 | import Debug.Trace |
35 | 35 | ||
36 | import Pretty hiding ((</>)) | 36 | import Pretty hiding ((</>)) |
37 | import Type | 37 | import CGExp |
38 | import IR | 38 | import IR |
39 | import qualified CoreToIR as IR | 39 | import qualified CoreToIR as IR |
40 | import Parser | ||
41 | import Typecheck hiding (Exp(..)) | ||
42 | 40 | ||
43 | type Modules = Map FilePath (Either Doc PolyEnv) | 41 | type Modules = Map FilePath (Either Doc PolyEnv) |
44 | type ModuleFetcher m = MName -> m (FilePath, String) | 42 | type ModuleFetcher m = MName -> m (FilePath, String) |
diff --git a/prototypes/Infer.hs b/Infer.hs index d4cb8775..d4cb8775 100644 --- a/prototypes/Infer.hs +++ b/Infer.hs | |||
diff --git a/Parser.hs b/Parser.hs deleted file mode 100644 index 80271495..00000000 --- a/Parser.hs +++ /dev/null | |||
@@ -1,695 +0,0 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
3 | {-# LANGUAGE PatternSynonyms #-} | ||
4 | {-# LANGUAGE ViewPatterns #-} | ||
5 | {-# LANGUAGE LambdaCase #-} | ||
6 | {-# LANGUAGE TypeFamilies #-} | ||
7 | {-# LANGUAGE FlexibleContexts #-} | ||
8 | module Parser | ||
9 | ( parseLC | ||
10 | , application | ||
11 | , appP' | ||
12 | , addContext | ||
13 | , P, valueDef | ||
14 | , toGuardTree, guardNodes | ||
15 | , eLam, pVar, eVar, eApp | ||
16 | , compileCasesOld | ||
17 | ) where | ||
18 | |||
19 | import Data.Function | ||
20 | import Data.Char | ||
21 | import Data.List | ||
22 | import Data.Maybe | ||
23 | import Data.Map (Map) | ||
24 | import qualified Data.Map as Map | ||
25 | import Data.Set (Set) | ||
26 | import qualified Data.Set as Set | ||
27 | import Data.Monoid | ||
28 | import Control.Applicative (some,liftA2,Alternative()) | ||
29 | import Control.Arrow | ||
30 | import Control.Monad | ||
31 | import Control.Monad.Except | ||
32 | import Control.Monad.State | ||
33 | import Control.Monad.Trans | ||
34 | import qualified Text.Parsec.Indentation.Char as I | ||
35 | import Text.Parsec.Indentation | ||
36 | import Text.Parsec hiding (optional) | ||
37 | |||
38 | import qualified Pretty as P | ||
39 | import Type | ||
40 | import ParserUtil | ||
41 | |||
42 | -- import Debug.Trace | ||
43 | |||
44 | -------------------------------------------------------------------------------- parser combinators | ||
45 | |||
46 | type P = P_ () -- no state for the parser | ||
47 | |||
48 | -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602 | ||
49 | try' s m = try m <?> s | ||
50 | |||
51 | qualified_ id = do | ||
52 | q <- try' "qualification" $ upperCase' <* dot | ||
53 | (N t qs n i) <- qualified_ id | ||
54 | return $ N t (q:qs) n i | ||
55 | <|> | ||
56 | id | ||
57 | where | ||
58 | upperCase' = (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum) | ||
59 | |||
60 | -------------------------------------------------------------------------------- position handling | ||
61 | |||
62 | -- compose ranges through getTag | ||
63 | infixl 9 <-> | ||
64 | a <-> b = getTag a `mappend` getTag b | ||
65 | |||
66 | addPos :: (Range -> a -> b) -> P a -> P b | ||
67 | addPos f m = do | ||
68 | p1 <- position | ||
69 | a <- m | ||
70 | p2 <- positionBeforeSpace | ||
71 | return $ f (Range p1 p2) a | ||
72 | |||
73 | addDPos = addPos (,) | ||
74 | addPPos = addPos PatR | ||
75 | addEPos = addPos ExpR | ||
76 | |||
77 | -------------------------------------------------------------------------------- identifiers | ||
78 | |||
79 | check msg p m = try' msg $ do | ||
80 | x <- m | ||
81 | if p x then return x else fail $ msg ++ " expected" | ||
82 | |||
83 | upperCase, lowerCase, symbols, colonSymbols :: P String | ||
84 | upperCase = check "uppercase ident" (isUpper . head) $ ident lcIdents | ||
85 | lowerCase = check "lowercase ident" (isLower . head) (ident lcIdents) <|> try (('_':) <$ char '_' <*> ident lcIdents) | ||
86 | symbols = check "symbols" ((/=':') . head) $ ident lcOps | ||
87 | colonSymbols = "Cons" <$ operator ":" <|> check "symbols" ((==':') . head) (ident lcOps) | ||
88 | |||
89 | -------------------------------------------------------------------------------- | ||
90 | |||
91 | typeConstructor, upperCaseIdent, typeVar, var, varId, qIdent, operator', conOperator, moduleName :: P Name | ||
92 | typeConstructor = upperCase <&> \i -> TypeN' i (P.text i) | ||
93 | upperCaseIdent = upperCase <&> ExpN | ||
94 | typeVar = (\p i -> TypeN' i $ P.text $ i ++ show p) <$> position <*> lowerCase | ||
95 | var = (\p i -> ExpN' i $ P.text $ i ++ show p) <$> position <*> lowerCase | ||
96 | qIdent = qualified_ (var <|> upperCaseIdent) | ||
97 | conOperator = (\p i -> ExpN' i $ P.text $ i ++ show p) <$> position <*> colonSymbols | ||
98 | varId = var <|> parens operator' | ||
99 | backquotedIdent = try' "backquoted" $ char '`' *> (ExpN <$> ((:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum))) <* char '`' <* whiteSpace | ||
100 | operator' = (\p i -> ExpN' i $ P.text $ i ++ show p) <$> position <*> symbols | ||
101 | <|> conOperator | ||
102 | <|> backquotedIdent | ||
103 | moduleName = qualified_ upperCaseIdent | ||
104 | |||
105 | -------------------------------------------------------------------------------- literals | ||
106 | |||
107 | literal :: P Lit | ||
108 | literal | ||
109 | = LFloat <$> try double | ||
110 | <|> LInt <$> try natural | ||
111 | <|> LChar <$> charLiteral | ||
112 | <|> LString <$> stringLiteral | ||
113 | |||
114 | -------------------------------------------------------------------------------- patterns | ||
115 | |||
116 | getP (PatR _ x) = x | ||
117 | appP' (PCon' r n []) ps = PCon' r n ps | ||
118 | appP' p ps = error $ "appP' " ++ P.ppShow (p, ps) | ||
119 | |||
120 | --------------------- | ||
121 | |||
122 | pattern', patternAtom :: P PatR | ||
123 | pattern' | ||
124 | = addPPos $ PPrec_ <$> pat <*> ((op >>= pat') <|> return []) | ||
125 | where | ||
126 | pat' o = do | ||
127 | (e, o') <- try $ (,) <$> pat <*> op | ||
128 | es <- pat' o' | ||
129 | return $ (o, e): es | ||
130 | <|> do | ||
131 | e <- pattern' | ||
132 | return [(o, e)] | ||
133 | |||
134 | pat = addPPos (PCon_ TWildcard <$> upperCaseIdent <*> many patternAtom) <|> patternAtom | ||
135 | |||
136 | op = addPPos $ PCon_ TWildcard <$> conOperator <*> pure [] | ||
137 | |||
138 | patternAtom = addPPos $ | ||
139 | PLit_ <$> literal | ||
140 | <|> PAt_ <$> try' "at pattern'" (var <* operator "@") <*> patternAtom | ||
141 | <|> PVar_ TWildcard <$> var | ||
142 | <|> Wildcard_ TWildcard <$ operator "_" | ||
143 | <|> PCon_ TWildcard <$> upperCaseIdent <*> pure [] | ||
144 | <|> pTuple <$> parens (commaSep1 pattern') | ||
145 | <|> PRecord_ <$> braces (commaSep $ (,) <$> var <* colon <*> pattern') | ||
146 | <|> getP . mkList <$> brackets (commaSep pattern') | ||
147 | where | ||
148 | mkList = foldr cons nil | ||
149 | where | ||
150 | nil = PCon' mempty (ExpN "Nil") [] | ||
151 | cons a b = PCon' mempty (ExpN "Cons") [a, b] | ||
152 | |||
153 | pTuple [PatR _ x] = x | ||
154 | pTuple xs = PTuple_ xs | ||
155 | |||
156 | -------------------------------------------------------------------------------- expressions | ||
157 | |||
158 | eTuple p [ExpR _ x] = ExpR p x | ||
159 | eTuple p xs = ExpR p $ ETuple_ xs | ||
160 | eRecord p xs = ExpR p $ ERecord_ xs | ||
161 | eNamedRecord p n xs = ExpR p $ ENamedRecord_ n xs | ||
162 | eVar p n = ExpR p $ EVar_ TWildcard n | ||
163 | eLam p e = ExpR (p <-> e) $ ELam_ Nothing p e | ||
164 | eApp a b = ExpR (a <-> b) $ EApp_ TWildcard a b | ||
165 | eTyping a b = ExpR (a <-> b) $ ETypeSig_ a b | ||
166 | eTyApp a b = ExpR (a <-> b) $ ETyApp_ TWildcard a b | ||
167 | |||
168 | application :: [ExpR] -> ExpR | ||
169 | application = foldl1 eApp | ||
170 | |||
171 | eLet :: DefinitionR -> ExpR -> ExpR | ||
172 | eLet (r, DValueDef False (ValueDef _{-TODO-} a b)) x = ExpR (r `mappend` getTag x) $ ELet_ a b x | ||
173 | eLet a b = error $ "eLet: " ++ P.ppShow a | ||
174 | |||
175 | eLets :: [DefinitionR] -> ExpR -> ExpR | ||
176 | eLets l a = foldr ($) a $ map eLet $ groupDefinitions l | ||
177 | |||
178 | desugarSwizzling :: [Char] -> ExpR -> ExpR | ||
179 | desugarSwizzling cs e = case map trC cs of | ||
180 | [c] -> c | ||
181 | cs -> application $ eVar mempty (vecName $ length cs): cs | ||
182 | where | ||
183 | trC c = eApp (expR $ EFieldProj_ TWildcard $ ExpN [tr c]) e | ||
184 | vecName n = ExpN $ "V" ++ show n | ||
185 | tr = \case | ||
186 | 'r' -> 'x' | ||
187 | 'g' -> 'y' | ||
188 | 'b' -> 'z' | ||
189 | 'a' -> 'w' | ||
190 | c -> c | ||
191 | |||
192 | --------------------- | ||
193 | |||
194 | withTypeSig p = do | ||
195 | e <- p | ||
196 | t <- optional $ operator "::" *> polytype | ||
197 | return $ maybe e (eTyping e) t | ||
198 | |||
199 | expression :: P ExpR | ||
200 | expression = withTypeSig $ | ||
201 | ifthenelse | ||
202 | <|> caseof | ||
203 | <|> letin | ||
204 | <|> lambda | ||
205 | <|> eApp <$> addPos eVar (const (ExpN "negate") <$> operator "-") <*> expressionOpAtom -- TODO: precedence | ||
206 | <|> expressionOpAtom | ||
207 | where | ||
208 | lambda :: P ExpR | ||
209 | lambda = (\(ps, e) -> foldr eLam e ps) <$> (operator "\\" *> ((,) <$> many patternAtom <* operator "->" <*> expression)) | ||
210 | |||
211 | ifthenelse :: P ExpR | ||
212 | ifthenelse = addPos (\r (a, b, c) -> eApp (eApp (eApp (eVar r (ExpN "PrimIfThenElse")) a) b) c) $ | ||
213 | (,,) <$ keyword "if" <*> expression <* keyword "then" <*> expression <* keyword "else" <*> expression | ||
214 | |||
215 | caseof :: P ExpR | ||
216 | caseof = addPos (uncurry . compileCases) $ (,) | ||
217 | <$ keyword "case" <*> expression <* keyword "of" | ||
218 | <*> localIndentation Ge (localAbsoluteIndentation $ some $ (,) <$> pattern' <*> localIndentation Gt (whereRHS $ operator "->")) | ||
219 | |||
220 | letin :: P ExpR | ||
221 | letin = eLets | ||
222 | <$ keyword "let" <*> localIndentation Ge (localAbsoluteIndentation $ some valueDef) | ||
223 | <* keyword "in" <*> expression | ||
224 | |||
225 | expressionOpAtom = addEPos $ EPrec_ <$> exp <*> ((op >>= expression') <|> return []) | ||
226 | where | ||
227 | expression' o = do | ||
228 | (e, o') <- try $ (,) <$> exp <*> op | ||
229 | es <- expression' o' | ||
230 | return $ (o, e): es | ||
231 | <|> (:[]) . (,) o <$> expression | ||
232 | |||
233 | exp = application <$> some expressionAtom | ||
234 | |||
235 | op = addPos eVar operator' | ||
236 | |||
237 | generator :: P (ExpR -> ExpR) | ||
238 | generator = do | ||
239 | pat <- try $ pattern' <* operator "<-" | ||
240 | exp <- expression | ||
241 | let v = ExpN "genVar" | ||
242 | pv = pVar mempty v | ||
243 | ev = eVar mempty v | ||
244 | return $ \e -> application | ||
245 | [ eVar mempty $ ExpN "concatMap" | ||
246 | , FunAlts 1 | ||
247 | [ ([toParPat pat], GuardExp e) | ||
248 | , ([mempty], GuardExp $ eVar mempty (ExpN "Nil")) | ||
249 | ] | ||
250 | , exp | ||
251 | ] | ||
252 | |||
253 | letdecl :: P (ExpR -> ExpR) | ||
254 | letdecl = keyword "let" *> (eLets . (:[]) <$> valueDef) | ||
255 | |||
256 | boolExpression :: P (ExpR -> ExpR) | ||
257 | boolExpression = do | ||
258 | pred <- expression | ||
259 | return $ \e -> application [eVar mempty $ ExpN "PrimIfThenElse", pred, e, eVar mempty (ExpN "Nil")] | ||
260 | |||
261 | listComprExp :: P ExpR | ||
262 | listComprExp = foldr ($) <$> | ||
263 | try' "List comprehension" (operator "[" *> (eApp (eVar mempty $ ExpN "singleton") <$> expression) <* operator "|") <*> | ||
264 | commaSep1 (generator <|> letdecl <|> boolExpression) <* operator "]" | ||
265 | |||
266 | listFromTo :: P ExpR | ||
267 | listFromTo = do | ||
268 | e1 <- try $ do | ||
269 | operator "[" | ||
270 | e1 <- expression | ||
271 | operator ".." | ||
272 | return e1 | ||
273 | e2 <- expression | ||
274 | operator "]" | ||
275 | return $ application [eVar mempty $ ExpN "fromTo", e1, e2] | ||
276 | |||
277 | expressionAtom :: P ExpR | ||
278 | expressionAtom = do | ||
279 | e <- expressionAtom_ | ||
280 | sw <- optional $ char '%' *> some (satisfy (`elem` ("xyzwrgba" :: [Char]))) <* whiteSpace | ||
281 | ts <- many $ do | ||
282 | operator "@" | ||
283 | typeAtom | ||
284 | return $ foldl eTyApp (maybe id desugarSwizzling sw e) ts | ||
285 | where | ||
286 | expressionAtom_ :: P ExpR | ||
287 | expressionAtom_ = | ||
288 | listFromTo | ||
289 | <|> listComprExp | ||
290 | <|> listExp | ||
291 | <|> addEPos (eLit <$> literal) | ||
292 | <|> recordExp | ||
293 | <|> recordExp' | ||
294 | <|> recordFieldProjection | ||
295 | <|> addPos eVar qIdent | ||
296 | <|> addPos eVar (try $ parens operator') | ||
297 | <|> addPos eTuple (parens $ commaSep expression) | ||
298 | where | ||
299 | recordExp :: P ExpR | ||
300 | recordExp = addPos eRecord $ braces $ commaSep $ (,) <$> var <* colon <*> expression | ||
301 | |||
302 | recordExp' :: P ExpR | ||
303 | recordExp' = try $ addPos (uncurry . eNamedRecord) $ (,) <$> upperCaseIdent <*> braces (commaSep $ (,) <$> var <* keyword "=" <*> expression) | ||
304 | |||
305 | recordFieldProjection :: P ExpR | ||
306 | recordFieldProjection = try $ flip eApp <$> addPos eVar var <*> | ||
307 | addEPos (EFieldProj_ TWildcard <$ {-runUnspaced $-} dot <*> {-Unspaced-} var) | ||
308 | |||
309 | eLit l@LInt{} = EApp_ TWildcard (eVar mempty (ExpN "fromInt")) $ expR $ ELit_ l | ||
310 | eLit l = ELit_ l | ||
311 | |||
312 | listExp :: P ExpR | ||
313 | listExp = addPos (\p -> foldr cons (nil p)) $ brackets $ commaSep expression | ||
314 | where | ||
315 | nil r = eVar (r{-TODO-}) $ ExpN "Nil" | ||
316 | cons a b = eApp (eApp (eVar mempty{-TODO-} (ExpN "Cons")) a) b | ||
317 | |||
318 | -------------------------------------------------------------------------------- types | ||
319 | |||
320 | tArr t a = ExpR (t <-> a) $ Forall_ Visible Nothing t a | ||
321 | tArrH t a = ExpR (t <-> a) $ Forall_ Hidden Nothing t a | ||
322 | addContext :: [ExpR] -> ExpR -> ExpR | ||
323 | addContext cs e = foldr tArrH e cs | ||
324 | |||
325 | --------------------- | ||
326 | |||
327 | typeVarKind :: P (Name, ExpR) | ||
328 | typeVarKind = | ||
329 | parens ((,) <$> typeVar <* operator "::" <*> monotype) | ||
330 | <|> (,) <$> typeVar <*> addEPos (pure Star_) | ||
331 | |||
332 | context :: P [ExpR] -- TODO | ||
333 | context = try' "type context" $ ((:[]) <$> tyC <|> parens (commaSep tyC)) <* operator "=>" | ||
334 | where | ||
335 | tyC = | ||
336 | ( addEPos (CEq_ <$> try (monotype <* operator "~") <*> (mkTypeFun <$> monotype)) | ||
337 | <|> foldl1 eApp <$> ((:) <$> (addEPos $ TCon_ TWildcard <$> typeConstructor) <*> many typeAtom) | ||
338 | ) | ||
339 | |||
340 | mkTypeFun e = case getArgs e of (n, reverse -> ts) -> TypeFun n ts | ||
341 | where | ||
342 | getArgs = \case | ||
343 | ExpR _ (TCon_ _ n) -> (n, []) | ||
344 | ExpR _ (EApp_ _ x y) -> id *** (y:) $ getArgs x | ||
345 | x -> error $ "mkTypeFun: " ++ P.ppShow x | ||
346 | |||
347 | polytype :: P ExpR | ||
348 | polytype = | ||
349 | do vs <- keyword "forall" *> some (addDPos typeVarKind) <* dot | ||
350 | t <- polytype | ||
351 | return $ foldr (\(p, (v, k)) t -> ExpR (p <> getTag t) $ Forall_ Visible (Just v) k t) t vs | ||
352 | <|> addContext <$> context <*> polytype | ||
353 | <|> monotype | ||
354 | |||
355 | polytypeCtx :: P [(Maybe Name, ExpR)] | ||
356 | polytypeCtx = | ||
357 | do vs <- keyword "forall" *> some typeVarKind <* dot | ||
358 | t <- polytypeCtx | ||
359 | return $ map (Just *** id) vs ++ t | ||
360 | <|> (++) <$> (map ((,) Nothing) <$> context) <*> polytypeCtx | ||
361 | <|> return [] | ||
362 | |||
363 | monotype :: P ExpR | ||
364 | monotype = do | ||
365 | t <- foldl1 eApp <$> some typeAtom | ||
366 | maybe t (tArr t) <$> optional (operator "->" *> polytype) | ||
367 | |||
368 | typeAtom :: P ExpR | ||
369 | typeAtom = addEPos $ | ||
370 | typeRecord | ||
371 | <|> Star_ <$ operator "*" | ||
372 | <|> EVar_ TWildcard <$> typeVar | ||
373 | <|> ELit_ <$> (LNat . fromIntegral <$> natural <|> literal) | ||
374 | <|> TCon_ TWildcard <$> typeConstructor | ||
375 | <|> tTuple <$> parens (commaSep monotype) | ||
376 | <|> EApp_ TWildcard (expR $ TCon_ TWildcard (TypeN' "List" "List")) <$> brackets monotype | ||
377 | where | ||
378 | tTuple [ExpR _ t] = t | ||
379 | tTuple ts = TTuple_ ts | ||
380 | |||
381 | typeRecord = undef "trec" $ do | ||
382 | braces (commaSep1 typeSignature >> optional (operator "|" >> void typeVar)) | ||
383 | where | ||
384 | undef msg = (const (error $ "not implemented: " ++ msg) <$>) | ||
385 | |||
386 | -------------------------------------------------------------------------------- function and value definitions | ||
387 | |||
388 | compileCasesOld :: Range -> ExpR -> [(PatR, Exp)] -> ExpR | ||
389 | compileCasesOld r e rs = eApp (alts 1 [eLam p r | (p, r) <- rs]) e | ||
390 | where | ||
391 | alts :: Int -> [ExpR] -> ExpR | ||
392 | alts _ [e] = e | ||
393 | alts i es = foldr eLam (ExpR (foldMap getTag es) $ EAlts_ [foldl eApp e vs | e <- es]) ps where | ||
394 | ps = take i $ map (pVar mempty . ExpN . ("alt" ++) . show) [1..] | ||
395 | vs = take i $ map (eVar mempty . ExpN . ("alt" ++) . show) [1..] | ||
396 | |||
397 | pVar r x = PatR r $ PVar_ TWildcard x | ||
398 | |||
399 | whereToBinds :: WhereBlock -> Binds Exp | ||
400 | whereToBinds = map eLet . groupDefinitions | ||
401 | where | ||
402 | eLet (r, DValueDef False (ValueDef _{-TODO-} a b)) = (a, b) | ||
403 | eLet a = error $ "eLet: " ++ P.ppShow a | ||
404 | |||
405 | compileWhereRHS :: WhereRHS -> GuardTree Exp | ||
406 | compileWhereRHS (WhereRHS r md) = maybe x (\w -> GuardWhere (whereToBinds w) x) md where | ||
407 | x = case r of | ||
408 | NoGuards e -> GuardExp e | ||
409 | Guards r{-TODO-} gs -> GuardAlts [GuardCon b (ConName $ ExpN "True") [] $ GuardExp e | (b, e) <- gs] | ||
410 | |||
411 | toParPat :: Pat -> ParPat Exp | ||
412 | toParPat (Pat p) = case p of | ||
413 | PLit_ l -> [PatLit l] | ||
414 | PTuple_ ps -> [PatCon (TupleName $ length ps) $ map toParPat ps] | ||
415 | PRecord_ rs -> error $ "toParPat: record " ++ P.ppShow rs --[(Name, b)] | ||
416 | PVar_ t v -> [PatVar v] | ||
417 | PCon_ t c ps -> [PatCon (ConName c) $ map toParPat ps] | ||
418 | PAt_ v p -> PatVar v: toParPat p | ||
419 | Wildcard_ _ -> [] | ||
420 | PPrec_ p ps -> [PatPrec (toParPat p) $ map (toParPat *** toParPat) ps] | ||
421 | |||
422 | funAlts0 :: GuardTree Exp -> Exp | ||
423 | funAlts0 t = FunAlts 0 [([], t)] | ||
424 | |||
425 | guardNodes :: [(Exp, ParPat Exp)] -> GuardTree Exp -> GuardTree Exp | ||
426 | guardNodes [] l = l | ||
427 | guardNodes ((v, ws): vs) e = GuardPat v ws $ guardNodes vs e | ||
428 | |||
429 | toGuardTree :: [Exp] -> [([ParPat Exp], GuardTree Exp)] -> GuardTree Exp | ||
430 | toGuardTree vs cs | ||
431 | = GuardAlts [guardNodes (zip vs ps) rhs | (ps, rhs) <- cs] | ||
432 | |||
433 | compileCases :: Range -> ExpR -> [(PatR, WhereRHS)] -> ExpR | ||
434 | compileCases r{-TODO-} e rs = funAlts0 $ toGuardTree [e] [([toParPat p], compileWhereRHS r) | (p, r) <- rs] | ||
435 | |||
436 | groupDefinitions :: [DefinitionR] -> [DefinitionR] | ||
437 | groupDefinitions defs = concatMap mkDef . map compileRHS . groupBy (f `on` snd) $ defs | ||
438 | where | ||
439 | f (h -> Just x) (h -> Just y) = x == y | ||
440 | f _ _ = False | ||
441 | |||
442 | h ( (PreValueDef (_, n) _ _)) = Just n | ||
443 | h ( (DValueDef _ (ValueDef _ p _))) = name p -- TODO | ||
444 | h ( (DTypeSig (TypeSig n _))) = Just n | ||
445 | h _ = Nothing | ||
446 | |||
447 | name (PVar' _ n) = Just n | ||
448 | name _ = Nothing | ||
449 | |||
450 | mkDef = \case | ||
451 | -- (r, PreInstanceDef c t ds) -> [(r, InstanceDef c t [v | (r, DValueDef v) <- groupDefinitions ds])] | ||
452 | x -> [x] | ||
453 | |||
454 | compileRHS :: [DefinitionR] -> DefinitionR | ||
455 | compileRHS ds = case ds of | ||
456 | ((r1, DTypeSig (TypeSig _ t)): ds@((r2, PreValueDef{}): _)) -> (r1 `mappend` r2, mkAlts (`eTyping` t) ds) | ||
457 | ds@((r, PreValueDef{}): _) -> (r, mkAlts id ds) | ||
458 | [x] -> x | ||
459 | where | ||
460 | mkAlts f ds@( (_, PreValueDef (r, n) _ _): _) | ||
461 | = DValueDef False $ ValueDef True (PVar' r n) $ f $ FunAlts i als | ||
462 | where | ||
463 | i = allSame $ map (length . fst) als | ||
464 | allSame (n:ns) | all (==n) ns = n | ||
465 | | otherwise = error $ "function alternatives have different arity: " ++ P.ppShow (n:ns) | ||
466 | als = [(map toParPat pats, compileWhereRHS rhs) | (_, PreValueDef _ pats rhs) <- ds] | ||
467 | |||
468 | --------------------- | ||
469 | |||
470 | valueDef :: P DefinitionR | ||
471 | valueDef = addDPos $ | ||
472 | (do | ||
473 | try' "function definition" $ do | ||
474 | n <- addDPos varId | ||
475 | localIndentation Gt $ do | ||
476 | pats <- many patternAtom | ||
477 | lookAhead $ operator "=" <|> operator "|" | ||
478 | return $ PreValueDef n pats | ||
479 | <|> do | ||
480 | try' "value definition" $ do | ||
481 | n <- pattern' | ||
482 | n2 <- optional $ do | ||
483 | op <- addDPos operator' | ||
484 | n2 <- pattern' | ||
485 | return (op, n2) | ||
486 | localIndentation Gt $ do | ||
487 | lookAhead $ operator "=" <|> operator "|" | ||
488 | return $ case n2 of | ||
489 | Nothing -> \e -> DValueDef False $ ValueDef True n $ funAlts0 $ compileWhereRHS e | ||
490 | Just (op, n2) -> PreValueDef op [n, n2] | ||
491 | ) | ||
492 | <*> localIndentation Gt (whereRHS $ operator "=") | ||
493 | |||
494 | whereRHS :: P () -> P WhereRHS | ||
495 | whereRHS delim = | ||
496 | WhereRHS <$> | ||
497 | ( NoGuards <$ delim <*> expression | ||
498 | <|> addPos Guards (many $ (,) <$ operator "|" <*> expression <* delim <*> expression) | ||
499 | ) <*> | ||
500 | ( Just . concat <$> (keyword "where" *> localIndentation Ge (localAbsoluteIndentation $ some $ (:[]) <$> valueDef <|> typeSignature)) | ||
501 | <|> return Nothing | ||
502 | ) | ||
503 | |||
504 | -------------------------------------------------------------------------------- class and instance definitions | ||
505 | |||
506 | whereBlock p = fromMaybe [] <$> optional (keyword "where" *> localIndentation Ge (localAbsoluteIndentation $ many p)) | ||
507 | |||
508 | classDef :: P DefinitionR | ||
509 | classDef = addDPos $ do | ||
510 | keyword "class" | ||
511 | localIndentation Gt $ ClassDef | ||
512 | <$> (fromMaybe [] <$> optional context) | ||
513 | <*> typeConstructor | ||
514 | <*> many typeVarKind | ||
515 | <*> (whereBlock typeSignature <&> \ds -> [d | (_, DTypeSig d) <- concat ds]) | ||
516 | |||
517 | instanceDef :: P DefinitionR | ||
518 | instanceDef = addDPos $ do | ||
519 | keyword "instance" | ||
520 | localIndentation Gt $ InstanceDef | ||
521 | <$> (fromMaybe [] <$> optional context) | ||
522 | <*> typeConstructor | ||
523 | <*> many typeAtom | ||
524 | <*> (whereBlock valueDef <&> \ds -> [v | (r, DValueDef False v) <- groupDefinitions ds]) | ||
525 | |||
526 | -------------------------------------------------------------------------------- data definition | ||
527 | |||
528 | fields = braces (commaSep $ FieldTy <$> (Just <$> ((,) <$> varId <*> pure False)) <* keyword "::" <* optional (operator "!") <*> polytype) | ||
529 | <|> many (FieldTy Nothing <$ optional (operator "!") <*> typeAtom) | ||
530 | |||
531 | fields' = braces (commaSep $ FieldTy <$> (Just <$> ((,) <$> varId <*> pure False)) <* keyword "::" <* optional (operator "!") <*> polytype) | ||
532 | <|> many (try $ FieldTy Nothing <$ optional (operator "!") <*> ty <* operator "->") | ||
533 | where | ||
534 | ty = foldl1 eApp <$> some typeAtom | ||
535 | |||
536 | dataDef :: P DefinitionR | ||
537 | dataDef = addDPos $ do | ||
538 | keyword "data" | ||
539 | localIndentation Gt $ do | ||
540 | tc <- typeConstructor | ||
541 | tvs <- many typeVarKind | ||
542 | do | ||
543 | do | ||
544 | keyword "where" | ||
545 | ds <- localIndentation Ge $ localAbsoluteIndentation $ many $ do | ||
546 | cs <- commaSep1 (addDPos upperCaseIdent) | ||
547 | localIndentation Gt $ do | ||
548 | t <- ConDef' <$ operator "::" <*> polytypeCtx <*> fields' <*> monotype | ||
549 | return [(p, (c, t)) | (p, c) <- cs] | ||
550 | return $ GADT tc tvs $ concat ds | ||
551 | <|> | ||
552 | do | ||
553 | operator "=" | ||
554 | ds <- sepBy (addDPos $ ConDef <$> upperCaseIdent <*> fields) $ operator "|" | ||
555 | derivingStm | ||
556 | return $ DDataDef tc tvs ds | ||
557 | where | ||
558 | derivingStm = optional $ keyword "deriving" <* (void typeConstructor <|> void (parens $ commaSep typeConstructor)) | ||
559 | |||
560 | -------------------------------------------------------------------------------- type synonym | ||
561 | |||
562 | typeSynonym :: P () | ||
563 | typeSynonym = void $ do | ||
564 | keyword "type" | ||
565 | localIndentation Gt $ do | ||
566 | typeConstructor | ||
567 | many typeVar | ||
568 | operator "=" | ||
569 | void polytype | ||
570 | |||
571 | -------------------------------------------------------------------------------- type family | ||
572 | |||
573 | typeFamily :: P DefinitionR | ||
574 | typeFamily = addDPos $ do | ||
575 | try $ keyword "type" >> keyword "family" | ||
576 | tc <- typeConstructor | ||
577 | tvs <- many typeVarKind | ||
578 | res <- optional $ do | ||
579 | operator "::" | ||
580 | monotype | ||
581 | return $ TypeFamilyDef tc tvs $ fromMaybe (expR Star_) res | ||
582 | |||
583 | -------------------------------------------------------------------------------- type signature | ||
584 | |||
585 | typeSignature :: P [DefinitionR] | ||
586 | typeSignature = do | ||
587 | ns <- try' "type signature" $ do | ||
588 | ns <- commaSep1 varId | ||
589 | localIndentation Gt $ operator "::" | ||
590 | return ns | ||
591 | t <- localIndentation Gt $ do | ||
592 | optional (operator "!") *> polytype | ||
593 | return [(mempty, DTypeSig $ TypeSig n t) | n <- ns] | ||
594 | |||
595 | axiom :: P [DefinitionR] | ||
596 | axiom = do | ||
597 | ns <- try' "axiom" $ do | ||
598 | ns <- commaSep1 (varId <|> upperCaseIdent) | ||
599 | localIndentation Gt $ operator "::" | ||
600 | return ns | ||
601 | t <- localIndentation Gt $ do | ||
602 | optional (operator "!") *> polytype | ||
603 | return [(mempty, DAxiom $ TypeSig n t) | n <- ns] | ||
604 | |||
605 | -------------------------------------------------------------------------------- fixity declarations | ||
606 | |||
607 | fixityDef :: P [DefinitionR] | ||
608 | fixityDef = do | ||
609 | dir <- Nothing <$ keyword "infix" | ||
610 | <|> Just FDLeft <$ keyword "infixl" | ||
611 | <|> Just FDRight <$ keyword "infixr" | ||
612 | localIndentation Gt $ do | ||
613 | i <- natural | ||
614 | ns <- commaSep1 (addDPos operator') | ||
615 | return [(p, PrecDef n (dir, fromIntegral i)) | (p, n) <- ns] | ||
616 | |||
617 | -------------------------------------------------------------------------------- modules | ||
618 | |||
619 | importDef :: P Name | ||
620 | importDef = do | ||
621 | keyword "import" | ||
622 | optional $ keyword "qualified" | ||
623 | n <- moduleName | ||
624 | let importlist = parens (commaSep (varId <|> upperCaseIdent)) | ||
625 | optional $ | ||
626 | (keyword "hiding" >> importlist) | ||
627 | <|> importlist | ||
628 | optional $ do | ||
629 | keyword "as" | ||
630 | moduleName | ||
631 | return n | ||
632 | |||
633 | parseExtensions :: P [Extension] | ||
634 | parseExtensions = do | ||
635 | try (string "{-#") | ||
636 | simpleSpace | ||
637 | string "LANGUAGE" | ||
638 | simpleSpace | ||
639 | s <- commaSep ext | ||
640 | simpleSpace | ||
641 | string "#-}" | ||
642 | simpleSpace | ||
643 | return s | ||
644 | where | ||
645 | simpleSpace = skipMany (satisfy isSpace) | ||
646 | |||
647 | ext = do | ||
648 | s <- some $ satisfy isAlphaNum | ||
649 | case s of | ||
650 | "NoImplicitPrelude" -> return NoImplicitPrelude | ||
651 | _ -> fail $ "language extension expected instead of " ++ s | ||
652 | |||
653 | export :: P Export | ||
654 | export = | ||
655 | ExportModule <$ keyword "module" <*> moduleName | ||
656 | <|> ExportId <$> varId | ||
657 | |||
658 | moduleDef :: FilePath -> P ModuleR | ||
659 | moduleDef fname = do | ||
660 | exts <- concat <$> many parseExtensions | ||
661 | whiteSpace | ||
662 | header <- optional $ do | ||
663 | modn <- keyword "module" *> moduleName | ||
664 | exps <- optional (parens $ commaSep export) | ||
665 | keyword "where" | ||
666 | return (modn, exps) | ||
667 | -- localAbsoluteIndentation $ do | ||
668 | do | ||
669 | idefs <- many importDef | ||
670 | -- TODO: unordered definitions | ||
671 | defs <- groupDefinitions . concat <$> many | ||
672 | ( (:[]) <$> dataDef | ||
673 | <|> concat <$ keyword "builtins" <*> localIndentation Gt (localAbsoluteIndentation $ many axiom) | ||
674 | <|> typeSignature | ||
675 | <|> (:[]) <$> typeFamily | ||
676 | <|> const [] <$> typeSynonym | ||
677 | <|> (:[]) <$> classDef | ||
678 | <|> (:[]) <$> valueDef | ||
679 | <|> fixityDef | ||
680 | <|> (:[]) <$> instanceDef | ||
681 | ) | ||
682 | return $ Module | ||
683 | { extensions = exts | ||
684 | , moduleImports = if NoImplicitPrelude `elem` exts | ||
685 | then idefs | ||
686 | else ExpN "Prelude": idefs | ||
687 | , moduleExports = join $ snd <$> header | ||
688 | , definitions = defs | ||
689 | } | ||
690 | |||
691 | -------------------------------------------------------------------------------- | ||
692 | |||
693 | parseLC :: MonadError ErrorMsg m => FilePath -> String -> m ModuleR | ||
694 | parseLC fname src = either throwParseError return . runParser' fname (moduleDef fname) $ src | ||
695 | |||
diff --git a/ParserUtil.hs b/ParserUtil.hs deleted file mode 100644 index 153d685f..00000000 --- a/ParserUtil.hs +++ /dev/null | |||
@@ -1,69 +0,0 @@ | |||
1 | module ParserUtil | ||
2 | ( module ParserUtil | ||
3 | , ParseError | ||
4 | ) where | ||
5 | |||
6 | import Control.Monad.Reader | ||
7 | import Control.Monad.Identity | ||
8 | import qualified Text.Parsec.Indentation.Char as I | ||
9 | import qualified Text.Parsec.Indentation.Token as I | ||
10 | import qualified Text.Parsec.Token as P | ||
11 | import Text.Parsec.Indentation as I | ||
12 | import Text.Parsec.Language (haskellDef) | ||
13 | import Text.Parsec hiding (optional) | ||
14 | import Text.Parsec.Pos | ||
15 | |||
16 | type P_ st = Parsec (I.IndentStream (I.CharIndentStream String)) SourcePos | ||
17 | |||
18 | {-# NoInline lexer #-} | ||
19 | lexer :: P.GenTokenParser | ||
20 | (I.IndentStream | ||
21 | (I.CharIndentStream String)) | ||
22 | SourcePos | ||
23 | Identity | ||
24 | lexer = I.makeTokenParser $ I.makeIndentLanguageDef haskellDef | ||
25 | |||
26 | position :: P_ st SourcePos | ||
27 | position = getPosition | ||
28 | |||
29 | positionBeforeSpace :: P_ st SourcePos | ||
30 | positionBeforeSpace = getState | ||
31 | |||
32 | optional :: P_ st a -> P_ st (Maybe a) | ||
33 | optional = optionMaybe | ||
34 | |||
35 | keyword :: String -> P_ st () | ||
36 | keyword = P.reserved lexer | ||
37 | |||
38 | operator :: String -> P_ st () | ||
39 | operator = P.reservedOp lexer | ||
40 | |||
41 | lcIdents = P.identifier lexer | ||
42 | lcOps = P.operator lexer | ||
43 | |||
44 | ident = id | ||
45 | --ident _ = P.identifier lexer | ||
46 | --identOp = P.operator lexer | ||
47 | parens = P.parens lexer | ||
48 | braces = P.braces lexer | ||
49 | brackets = P.brackets lexer | ||
50 | commaSep = P.commaSep lexer | ||
51 | commaSep1 = P.commaSep1 lexer | ||
52 | dot = P.dot lexer | ||
53 | comma = P.comma lexer | ||
54 | colon = P.colon lexer | ||
55 | natural = P.natural lexer | ||
56 | integer = P.integer lexer | ||
57 | double = P.float lexer | ||
58 | charLiteral = P.charLiteral lexer | ||
59 | stringLiteral = P.stringLiteral lexer | ||
60 | whiteSpace = P.whiteSpace lexer | ||
61 | |||
62 | runParser' :: SourceName -> P_ st a -> String -> Either ParseError a | ||
63 | runParser' fname p src = runParser p' (newPos "" 0 0) "" $ mkIndentStream 0 infIndentation True Ge $ I.mkCharIndentStream src | ||
64 | where | ||
65 | p' = do | ||
66 | getPosition >>= setState | ||
67 | setPosition =<< flip setSourceName fname <$> getPosition | ||
68 | p <* eof | ||
69 | |||
diff --git a/Type.hs b/Type.hs deleted file mode 100644 index af0a1206..00000000 --- a/Type.hs +++ /dev/null | |||
@@ -1,1707 +0,0 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE PatternSynonyms #-} | ||
4 | {-# LANGUAGE DeriveFunctor #-} | ||
5 | {-# LANGUAGE DeriveFoldable #-} | ||
6 | {-# LANGUAGE DeriveTraversable #-} | ||
7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
8 | {-# LANGUAGE NoMonomorphismRestriction #-} | ||
9 | {-# LANGUAGE TypeSynonymInstances #-} | ||
10 | {-# LANGUAGE FlexibleInstances #-} | ||
11 | {-# LANGUAGE FlexibleContexts #-} | ||
12 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
13 | {-# LANGUAGE StandaloneDeriving #-} | ||
14 | {-# LANGUAGE ViewPatterns #-} | ||
15 | {-# LANGUAGE TypeFamilies #-} | ||
16 | {-# LANGUAGE ScopedTypeVariables #-} | ||
17 | {-# LANGUAGE UndecidableInstances #-} | ||
18 | module Type where | ||
19 | |||
20 | import Data.Function | ||
21 | import Data.Char | ||
22 | import Data.Either | ||
23 | import Data.String | ||
24 | import Data.Maybe | ||
25 | import Data.List | ||
26 | import Data.Set (Set) | ||
27 | import qualified Data.Set as Set | ||
28 | import Data.Map (Map) | ||
29 | import qualified Data.Map as Map | ||
30 | import Data.Monoid | ||
31 | import Data.Foldable hiding (foldr) | ||
32 | import Data.Traversable | ||
33 | import Control.Monad.Except | ||
34 | import Control.Monad.State | ||
35 | import Control.Monad.Identity | ||
36 | import Control.Monad.Reader | ||
37 | import Control.Monad.Writer | ||
38 | import Control.Applicative | ||
39 | import Control.Arrow hiding ((<+>)) | ||
40 | import Text.Parsec.Pos | ||
41 | import Text.Parsec.Error | ||
42 | import GHC.Exts (Constraint) | ||
43 | import Debug.Trace | ||
44 | |||
45 | import ParserUtil (ParseError) | ||
46 | import Pretty | ||
47 | |||
48 | trace' x = trace (ppShow x) x | ||
49 | |||
50 | (<&>) = flip (<$>) | ||
51 | |||
52 | -------------------------------------------------------------------------------- literals | ||
53 | |||
54 | data Lit | ||
55 | = LInt Integer | ||
56 | | LNat Int -- invariant property: >= 0 | ||
57 | | LChar Char | ||
58 | | LString String | ||
59 | | LFloat Double | ||
60 | deriving (Eq, Ord) | ||
61 | |||
62 | -- literals in expressions | ||
63 | pattern EInt a = ELit (LInt a) | ||
64 | pattern ENat a = ELit (LNat a) | ||
65 | pattern EChar a = ELit (LChar a) | ||
66 | pattern EString a = ELit (LString a) | ||
67 | pattern EFloat a = ELit (LFloat a) | ||
68 | |||
69 | -------------------------------------------------------------------------------- patterns | ||
70 | |||
71 | -- TODO: remove | ||
72 | data Pat_ t c v b -- type; constructor info; variable info; sub-pattern | ||
73 | = PLit_ Lit | ||
74 | | PVar_ t v | ||
75 | | PCon_ t c [b] | ||
76 | | PTuple_ [b] | ||
77 | | PRecord_ [(Name, b)] | ||
78 | | PAt_ v b -- used before pattern compilation | ||
79 | | Wildcard_ t -- TODO: merge into PVar | ||
80 | -- aux | ||
81 | | PPrec_ b [(b{-TODO: Name-}, b)] -- used before precedence calculation | ||
82 | deriving (Functor,Foldable,Traversable) | ||
83 | |||
84 | -- TODO: remove | ||
85 | instance Eq Pat where (==) = error "Eq Pat" | ||
86 | instance Ord Pat where compare = error "Ord Pat" | ||
87 | |||
88 | mapPat :: (t -> t') -> (c -> c') -> (v -> v') -> Pat_ t c v b -> Pat_ t' c' v' b | ||
89 | mapPat tf f g = \case | ||
90 | PLit_ l -> PLit_ l | ||
91 | PVar_ t v -> PVar_ (tf t) $ g v | ||
92 | PCon_ t c p -> PCon_ (tf t) (f c) p | ||
93 | PTuple_ p -> PTuple_ p | ||
94 | PRecord_ p -> PRecord_ p -- $ map (g *** id) p | ||
95 | PAt_ v p -> PAt_ (g v) p | ||
96 | Wildcard_ t -> Wildcard_ (tf t) | ||
97 | PPrec_ b bs -> PPrec_ b bs | ||
98 | |||
99 | -------------------------------------------- | ||
100 | |||
101 | data PatR = PatR Range (Pat_ ExpR Name Name PatR) | ||
102 | |||
103 | -- TODO: remove | ||
104 | pattern PatR' a <- PatR _ a where | ||
105 | PatR' a = PatR mempty a | ||
106 | |||
107 | pattern PVar' a b = PatR a (PVar_ TWildcard b) | ||
108 | pattern PCon' a b c = PatR a (PCon_ TWildcard b c) | ||
109 | |||
110 | -------------------------------------------- | ||
111 | |||
112 | type Pat = PatR | ||
113 | |||
114 | pattern Pat a <- PatR _ a where | ||
115 | Pat a = PatR mempty a | ||
116 | |||
117 | pattern PAt v l = Pat (PAt_ v l) | ||
118 | pattern PLit l = Pat (PLit_ l) | ||
119 | pattern PVar t l = Pat (PVar_ t l) | ||
120 | pattern PCon t c l = Pat (PCon_ t c l) | ||
121 | pattern PTuple l = Pat (PTuple_ l) | ||
122 | pattern Wildcard t = Pat (Wildcard_ t) | ||
123 | |||
124 | patternVars' :: ParPat Exp -> [Name] | ||
125 | patternVars' = concatMap $ \case | ||
126 | PatVar n -> [n] | ||
127 | PatCon _ ps -> foldMap patternVars' ps | ||
128 | PatLit{} -> [] | ||
129 | ViewPat _ p -> patternVars' p | ||
130 | PatPrec p ps -> patternVars' p ++ foldMap patternVars' (map snd ps) | ||
131 | |||
132 | patternVars :: Pat -> [(Name, Exp)] | ||
133 | patternVars (Pat p) = case p of | ||
134 | PVar_ t v -> [(v, t)] | ||
135 | PAt_ v p -> [(v, tyOfPat p)] | ||
136 | p -> foldMap patternVars p | ||
137 | |||
138 | -------------------------------------------------------------------------------- expressions | ||
139 | |||
140 | data Exp_ v p b -- TODO: remove p | ||
141 | = Star_ | ||
142 | | ELit_ Lit | ||
143 | |||
144 | | EVar_ b v | ||
145 | | TCon_ b v -- TODO: use it or remove it | ||
146 | | TWildcard_ -- star kinded type variable | ||
147 | -- | TFun_ v [a] -- TODO | ||
148 | |||
149 | | Forall_ Visibility (Maybe v) b b | ||
150 | | ELam_ (Maybe b){-Just:hidden + type-} p b | ||
151 | | EApp_ b b b | ||
152 | | ETyApp_ b b b | ||
153 | | EPrec_ b [(b, b)] -- aux: used only before precedence calculation | ||
154 | | ELet_ p b b -- TODO: remove? | ||
155 | |||
156 | | TRecord_ (Map v b) | ||
157 | | ERecord_ [(Name, b)] | ||
158 | | EFieldProj_ b Name | ||
159 | |||
160 | | TTuple_ [b] -- TODO: remove? | ||
161 | | ETuple_ [b] -- TODO: remove? | ||
162 | | ENamedRecord_ Name [(Name, b)] | ||
163 | |||
164 | | WRefl_ b | ||
165 | | CEq_ b (TypeFun v b) -- unification between a type and a fully applied type function; CEq t f: t ~ f | ||
166 | -- TODO: merge with CUnify? | ||
167 | | CUnify_ b b -- unification between (non-type-function) types; CUnify t s: t ~ s | ||
168 | | Split_ b b b -- Split x y z: x, y, z are records; fields of x = disjoint union of the fields of y and z | ||
169 | |||
170 | | ETypeSig_ b b | ||
171 | | Case_ b b [(p {-Name, [Name{-v-}]-}, b)] -- simple case expression, not used yet | ||
172 | | WhereBlock_ [(Name{-v-}, b)] b -- not used yet | ||
173 | | PrimFun b Name [b] Int -- type, name, collected args, arity | ||
174 | | FunAlts_ Int{-number of parameters-} [([ParPat b], GuardTree b)] | ||
175 | -- TODO: remove | ||
176 | | EAlts_ [b] -- function alternatives | ||
177 | | ENext_ Doc b -- go to next alternative | ||
178 | |||
179 | deriving (Eq,Ord,Functor,Foldable,Traversable) -- TODO: elim Eq instance | ||
180 | |||
181 | -- TODO! remove | ||
182 | instance Eq Doc where _ == _ = True | ||
183 | instance Ord Doc where _ `compare` _ = EQ | ||
184 | |||
185 | type ParPat e = [Pat' e] | ||
186 | |||
187 | data ConName | ||
188 | = TupleName Int | ||
189 | | ConName Name | ||
190 | -- | ConLit Lit | ||
191 | deriving (Eq, Ord) | ||
192 | |||
193 | data Pat' e | ||
194 | = PatVar Name -- v | ||
195 | | PatCon ConName [ParPat e] | ||
196 | | PatLit Lit | ||
197 | | ViewPat e (ParPat e) | ||
198 | | PatPrec (ParPat e) [(ParPat e{-TODO: Name-}, ParPat e)] -- used before precedence calculation | ||
199 | deriving (Eq,Ord,Functor,Foldable,Traversable) -- TODO: elim Eq instance | ||
200 | |||
201 | data GuardTree e | ||
202 | = GuardCon e ConName [ParPat e] (GuardTree e) | ||
203 | | GuardWhere (Binds e) (GuardTree e) | ||
204 | | GuardAlts [GuardTree e] | ||
205 | | GuardExp e | ||
206 | | GuardPat e (ParPat e) (GuardTree e) -- used only before precedence calculation | ||
207 | deriving (Eq,Ord,Functor,Foldable,Traversable) -- TODO: elim Eq instance | ||
208 | |||
209 | type Binds e = [(Pat, e)] -- TODO: replace with Env | ||
210 | |||
211 | data Visibility = Visible | Hidden | Irrelevant deriving (Eq, Ord) | ||
212 | |||
213 | type ExpR = Exp | ||
214 | |||
215 | pattern ExpR r e <- (peelThunkR -> (r, e)) where | ||
216 | ExpR r e = ExpTh r mempty e | ||
217 | |||
218 | expR = ExpR mempty | ||
219 | pattern EVarR' a b = ExpR a (EVar_ TWildcard b) | ||
220 | pattern EAppR' a b c = ExpR a (EApp_ TWildcard b c) | ||
221 | --pattern ELamR' a b c = ExpR a (ELam_ False b c) | ||
222 | |||
223 | pattern ExpR' a <- ExpR _ a where | ||
224 | ExpR' a = ExpR mempty a | ||
225 | |||
226 | pattern TWildcard = ExpR' TWildcard_ | ||
227 | |||
228 | data Exp = ExpTh Range Subst Exp' | ||
229 | type Exp' = Exp_ Name Pat Exp | ||
230 | |||
231 | type Ty = Exp | ||
232 | |||
233 | pattern Exp a <- (peelThunk -> a) where | ||
234 | Exp a = thunk a | ||
235 | |||
236 | thunk = ExpTh mempty{-TODO: review this-} mempty | ||
237 | |||
238 | -- TODO: eliminate or improve | ||
239 | instance Eq Exp where Exp a == Exp b = a == b | ||
240 | instance Ord Exp where Exp a `compare` Exp b = a `compare` b | ||
241 | |||
242 | pattern TCon k a <- Exp (TCon_ k (TypeIdN a)) where | ||
243 | TCon k a = Exp (TCon_ k (TypeIdN' a "typecon")) | ||
244 | |||
245 | pattern Con0 t a = TVar t (ExpN a) | ||
246 | |||
247 | pattern Star = Exp Star_ | ||
248 | |||
249 | pattern TRecord b = Exp (TRecord_ b) | ||
250 | pattern TTuple b = Exp (TTuple_ b) | ||
251 | pattern TUnit = TTuple [] | ||
252 | pattern CEq a b = Exp (CEq_ a b) | ||
253 | pattern CUnify a b = Exp (CUnify_ a b) | ||
254 | pattern Split a b c = Exp (Split_ a b c) | ||
255 | pattern Forall a b c = Exp (Forall_ Visible (Just a) b c) | ||
256 | pattern TArr a b = Exp (Forall_ Visible Nothing a b) | ||
257 | pattern ELit a = Exp (ELit_ a) | ||
258 | pattern EVar a <- Exp (EVar_ _ a) | ||
259 | pattern TVar k b = Exp (EVar_ k b) | ||
260 | pattern EApp a b <- Exp (EApp_ _ a b) | ||
261 | pattern TApp k a b = Exp (EApp_ k a b) | ||
262 | pattern ETyApp k a b = Exp (ETyApp_ k a b) | ||
263 | pattern ELam a b = Exp (ELam_ Nothing a b) | ||
264 | pattern ELet a b c = Exp (ELet_ a b c) | ||
265 | pattern ETuple a = Exp (ETuple_ a) | ||
266 | pattern ERecord b = Exp (ERecord_ b) | ||
267 | pattern EFieldProj k a = Exp (EFieldProj_ k a) | ||
268 | pattern EAlts b = Exp (EAlts_ b) | ||
269 | pattern ENext i k = Exp (ENext_ i k) | ||
270 | pattern Case t b as = Exp (Case_ t b as) | ||
271 | pattern WRefl k = Exp (WRefl_ k) | ||
272 | pattern FunAlts i as = Exp (FunAlts_ i as) | ||
273 | |||
274 | pattern A0 x <- EVar (ExpIdN x) | ||
275 | pattern A1 f x <- EApp (A0 f) x | ||
276 | pattern A2 f x y <- EApp (A1 f x) y | ||
277 | pattern A3 f x y z <- EApp (A2 f x y) z | ||
278 | pattern A4 f x y z v <- EApp (A3 f x y z) v | ||
279 | pattern A5 f x y z v w <- EApp (A4 f x y z v) w | ||
280 | pattern A6 f x y z v w q <- EApp (A5 f x y z v w) q | ||
281 | pattern A7 f x y z v w q r <- EApp (A6 f x y z v w q) r | ||
282 | pattern A8 f x y z v w q r s <- EApp (A7 f x y z v w q r) s | ||
283 | pattern A9 f x y z v w q r s t <- EApp (A8 f x y z v w q r s) t | ||
284 | pattern A10 f x y z v w q r s t a <- EApp (A9 f x y z v w q r s t) a | ||
285 | pattern A11 f x y z v w q r s t a b <- EApp (A10 f x y z v w q r s t a) b | ||
286 | |||
287 | infixr 7 ~>, ~~> | ||
288 | a ~> b = TArr a b | ||
289 | |||
290 | (~~>) :: [Exp] -> Exp -> Exp | ||
291 | args ~~> res = foldr (~>) res args | ||
292 | |||
293 | infix 4 ~~, ~~~ | ||
294 | (~~) = CEq | ||
295 | (~~~) = CUnify | ||
296 | |||
297 | buildApp :: (Exp -> Exp) -> Exp -> [Exp] -> Exp | ||
298 | buildApp n restype args = f restype $ reverse args | ||
299 | where | ||
300 | f ty [] = n ty | ||
301 | f ty (a:as) = TApp ty (f (tyOf a ~> ty) as) a | ||
302 | |||
303 | |||
304 | mapExp_ :: (PShow v, PShow p, PShow b, Ord v') => (v -> v') -> (p -> p') -> Exp_ v p b -> Exp_ v' p' b | ||
305 | mapExp_ vf f = \case | ||
306 | ELit_ x -> ELit_ x | ||
307 | EVar_ k x -> EVar_ k $ vf x | ||
308 | EApp_ k x y -> EApp_ k x y | ||
309 | ELam_ h x y -> ELam_ h (f x) y | ||
310 | ELet_ x y z -> ELet_ (f x) y z | ||
311 | ETuple_ x -> ETuple_ x | ||
312 | ERecord_ x -> ERecord_ $ x --map (vf *** id) x | ||
313 | ENamedRecord_ n x -> ENamedRecord_ n x --(vf n) $ map (vf *** id) x | ||
314 | EFieldProj_ k x -> EFieldProj_ k x -- $ vf x | ||
315 | ETypeSig_ x y -> ETypeSig_ x y | ||
316 | EAlts_ x -> EAlts_ x | ||
317 | Case_ t x xs -> Case_ t x $ map (f *** id) xs | ||
318 | ENext_ i k -> ENext_ i k | ||
319 | ETyApp_ k b t -> ETyApp_ k b t | ||
320 | PrimFun k a b c -> PrimFun k a b c | ||
321 | Star_ -> Star_ | ||
322 | TCon_ k v -> TCon_ k (vf v) | ||
323 | -- | TFun_ f [a] | ||
324 | Forall_ h mv b1 b2 -> Forall_ h (vf <$> mv) b1 b2 | ||
325 | TTuple_ bs -> TTuple_ bs | ||
326 | TRecord_ m -> TRecord_ $ Map.fromList $ map (vf *** id) $ Map.toList m -- (Map v b) | ||
327 | CEq_ a (TypeFun n as) -> CEq_ a (TypeFun (vf n) as) | ||
328 | CUnify_ a1 a2 -> CUnify_ a1 a2 | ||
329 | Split_ a1 a2 a3 -> Split_ a1 a2 a3 | ||
330 | WRefl_ k -> WRefl_ k | ||
331 | TWildcard_ -> TWildcard_ | ||
332 | EPrec_ e es -> EPrec_ e es | ||
333 | FunAlts_ i as -> FunAlts_ i as | ||
334 | x -> error $ "mapExp: " ++ ppShow x | ||
335 | |||
336 | --traverseExp :: (Applicative m, Ord v') => (v -> v') -> (t -> m t') -> Exp_ v p t -> m (Exp_ v' p t') | ||
337 | traverseExp nf f = fmap (mapExp_ nf id) . traverse f | ||
338 | |||
339 | ---------------- | ||
340 | |||
341 | data TypeFun n a = TypeFun n [a] | ||
342 | deriving (Eq,Ord,Functor,Foldable,Traversable) | ||
343 | |||
344 | type TypeFunT = TypeFun IdN Exp | ||
345 | |||
346 | -------------------------------------------------------------------------------- cached type inference | ||
347 | |||
348 | inferLit :: Lit -> Exp | ||
349 | inferLit a = thunk $ TCon_ (thunk Star_) $ flip TypeIdN' "typecon" $ case a of | ||
350 | LInt _ -> "Int" | ||
351 | LChar _ -> "Char" | ||
352 | LFloat _ -> "Float" | ||
353 | LString _ -> "String" | ||
354 | LNat _ -> "Nat" | ||
355 | |||
356 | tyFunRes :: Exp -> Exp | ||
357 | tyFunRes = \case | ||
358 | TArr a b -> b | ||
359 | x -> error $ "tyFunRes: not implemented " ++ ppShow x | ||
360 | |||
361 | tyOf :: Exp -> Exp | ||
362 | tyOf = \case | ||
363 | Exp t -> case t of | ||
364 | ELit_ l -> inferLit l | ||
365 | EVar_ k _ -> k | ||
366 | EApp_ k _ _ -> k | ||
367 | ETyApp_ k _ _ -> k | ||
368 | ETuple_ es -> TTuple $ map tyOf es | ||
369 | ELam_ (Just k) _ _ -> k | ||
370 | ELam_ Nothing (tyOfPat -> a) (tyOf -> b) -> Exp $ Forall_ Visible Nothing{-TODO-} a b | ||
371 | Case_ t _ _ -> t | ||
372 | ETypeSig_ b t -> t -- tyOf b | ||
373 | ELet_ _ _ e -> tyOf e | ||
374 | ERecord_ (unzip -> (fs, es)) -> TRecord $ Map.fromList $ zip fs $ map tyOf es | ||
375 | EFieldProj_ k _ -> k | ||
376 | EAlts_ bs -> tyOf $ head bs | ||
377 | ENext_ _ k -> k | ||
378 | PrimFun k _ _ _ -> k | ||
379 | -- was types | ||
380 | Star_ -> Star | ||
381 | TCon_ k _ -> k | ||
382 | Forall_ _ _ _ _ -> Star | ||
383 | TTuple_ _ -> Star | ||
384 | TRecord_ _ -> Star | ||
385 | CEq_ _ _ -> Star | ||
386 | CUnify_ _ _ -> Star | ||
387 | Split_ _ _ _ -> Star | ||
388 | WRefl_ k -> k | ||
389 | TWildcard_ -> TWildcard | ||
390 | e -> error $ "tyOf " ++ ppShow e | ||
391 | |||
392 | tyOfPat :: Pat -> Exp | ||
393 | tyOfPat = \case | ||
394 | PCon t _ _ -> t | ||
395 | PVar t _ -> t | ||
396 | Wildcard t -> t | ||
397 | PLit l -> inferLit l | ||
398 | PTuple xs -> thunk $ TTuple_ $ map tyOfPat xs | ||
399 | -- PRecord xs -> [(Name, b)] | ||
400 | PAt _ p -> tyOfPat p | ||
401 | e -> error $ "tyOfPat " ++ ppShow e | ||
402 | |||
403 | isStar = \case | ||
404 | Star -> True | ||
405 | _ -> False | ||
406 | |||
407 | -------------------------------------------------------------------------------- tag handling | ||
408 | |||
409 | class GetTag c where | ||
410 | type Tag c | ||
411 | getTag :: c -> Tag c | ||
412 | |||
413 | instance GetTag ExpR where | ||
414 | type Tag ExpR = Range | ||
415 | getTag (ExpR a _) = a | ||
416 | instance GetTag PatR where | ||
417 | type Tag PatR = Range | ||
418 | getTag (PatR a _) = a | ||
419 | |||
420 | -------------------------------------------------------------------------------- names | ||
421 | |||
422 | data NameSpace = TypeNS | ExpNS | ||
423 | deriving (Eq, Ord) | ||
424 | |||
425 | -- TODO: more structure instead of Doc | ||
426 | data NameInfo = NameInfo (Maybe Fixity) Doc | ||
427 | |||
428 | data N = N | ||
429 | { nameSpace :: NameSpace | ||
430 | , qualifier :: [String] | ||
431 | , nName :: String | ||
432 | , nameInfo :: NameInfo | ||
433 | } | ||
434 | |||
435 | instance Eq N where N a b c d == N a' b' c' d' = (a, b, c) == (a', b', c') | ||
436 | instance Ord N where N a b c d `compare` N a' b' c' d' = (a, b, c) `compare` (a', b', c') | ||
437 | |||
438 | type Fixity = (Maybe FixityDir, Int) | ||
439 | data FixityDir = FDLeft | FDRight | ||
440 | |||
441 | pattern ExpN n <- N ExpNS [] n _ where | ||
442 | ExpN n = N ExpNS [] n (NameInfo Nothing "exp") | ||
443 | pattern ExpN' n i = N ExpNS [] n (NameInfo Nothing i) | ||
444 | pattern TypeN n <- N TypeNS [] n _ where | ||
445 | TypeN n = N TypeNS [] n (NameInfo Nothing "type") | ||
446 | pattern TypeN' n i = N TypeNS [] n (NameInfo Nothing i) | ||
447 | |||
448 | addPrefix :: String -> Name -> Name | ||
449 | addPrefix s (N a b c d) = N a b (s ++ c) d | ||
450 | |||
451 | -- TODO: rename/eliminate | ||
452 | type Name = N | ||
453 | type TName = N | ||
454 | type TCName = N -- type constructor name; if this turns out to be slow use Int or ADT instead of String | ||
455 | type EName = N | ||
456 | type FName = N | ||
457 | type MName = N -- module name | ||
458 | type ClassName = N | ||
459 | |||
460 | toExpN (N _ a b i) = N ExpNS a b i | ||
461 | toTypeN (N _ a b i) = N TypeNS a b i | ||
462 | isTypeVar (N ns _ _ _) = ns == TypeNS | ||
463 | isConstr (N _ _ (c:_) _) = isUpper c || c == ':' | ||
464 | |||
465 | -------------------------------------------------------------------------------- error handling | ||
466 | |||
467 | -- TODO: add more structure to support desugaring | ||
468 | data Range | ||
469 | = Range SourcePos SourcePos | ||
470 | | NoRange | ||
471 | |||
472 | instance Monoid Range where | ||
473 | mempty = NoRange | ||
474 | Range a1 a2 `mappend` Range b1 b2 = Range (min a1 a2) (max b1 b2) | ||
475 | NoRange `mappend` a = a | ||
476 | a `mappend` b = a | ||
477 | |||
478 | type WithRange = (,) Range | ||
479 | pattern WithRange a b = (a, b) | ||
480 | |||
481 | -------------------------------------------------------------------------------- | ||
482 | |||
483 | type WithExplanation = (,) Doc | ||
484 | |||
485 | pattern WithExplanation d x = (d, x) | ||
486 | |||
487 | -- TODO: add more structure | ||
488 | data ErrorMsg | ||
489 | = AddRange Range ErrorMsg | ||
490 | | InFile String ErrorMsg | ||
491 | | ErrorCtx Doc ErrorMsg | ||
492 | | ErrorMsg Doc | ||
493 | | EParseError ParseError | ||
494 | | UnificationError Exp Exp [WithExplanation [Exp]] | ||
495 | |||
496 | instance Monoid ErrorMsg where | ||
497 | mempty = ErrorMsg "<<>>" | ||
498 | mappend a b = a | ||
499 | |||
500 | instance Show ErrorMsg where | ||
501 | show = show . f Nothing Nothing Nothing where | ||
502 | f d file rng = \case | ||
503 | InFile s e -> f d (Just s) Nothing e | ||
504 | AddRange NoRange e -> {- showRange file (Just r) <$$> -} f d file rng e | ||
505 | AddRange r e -> {- showRange file (Just r) <$$> -} f d file (Just r) e | ||
506 | ErrorCtx d e -> {-"during" <+> d <$$> -} f (Just d) file rng e | ||
507 | EParseError pe -> text $ show pe | ||
508 | ErrorMsg e -> maybe "" ("during" <+>) d <$$> (showRange file rng) <$$> e | ||
509 | UnificationError a b tys -> maybe "" ("during" <+>) d <$$> (showRange file rng) <$$> "cannot unify" <+> pShow a </> "with" <+> pShow b | ||
510 | <$$> "----------- equations" | ||
511 | <$$> vcat (map (\(s, l) -> s <$$> vcat (map pShow l)) tys) | ||
512 | |||
513 | dummyPos = newPos "" 0 0 | ||
514 | |||
515 | showErr :: ErrorMsg -> (SourcePos, SourcePos, String) | ||
516 | showErr e = (i, j, show msg) | ||
517 | where | ||
518 | (r, msg) = f Nothing e | ||
519 | (i, j) = case r of | ||
520 | Just (Range i j) -> (i, j) | ||
521 | _ -> (dummyPos, dummyPos) | ||
522 | f rng = \case | ||
523 | InFile s e -> f Nothing e | ||
524 | AddRange r e -> f (Just r) e | ||
525 | ErrorCtx d e -> {-(("during" <+> d) <+>) <$> -} f rng e | ||
526 | EParseError pe -> (Just $ Range p (incSourceColumn p 1), {-vcat $ map (text . messageString) $ errorMessages-} text $ show pe) | ||
527 | where p = errorPos pe | ||
528 | ErrorMsg d -> (rng, d) | ||
529 | UnificationError a b tys -> (rng, "cannot unify" <+> pShow a </> "with" <+> pShow b) | ||
530 | |||
531 | type ErrorT = ExceptT ErrorMsg | ||
532 | |||
533 | throwParseError = throwError . EParseError | ||
534 | |||
535 | mapError f m = catchError m $ throwError . f | ||
536 | |||
537 | addCtx d = mapError (ErrorCtx d) | ||
538 | |||
539 | addRange :: MonadError ErrorMsg m => Range -> m a -> m a | ||
540 | addRange NoRange = id | ||
541 | addRange r = mapError $ AddRange r | ||
542 | |||
543 | --throwErrorTCM :: Doc -> TCM a | ||
544 | throwErrorTCM = throwError . ErrorMsg | ||
545 | |||
546 | showRange :: Maybe String -> Maybe Range -> Doc | ||
547 | showRange Nothing Nothing = "no file position" | ||
548 | showRange Nothing (Just _) = "no file" | ||
549 | showRange (Just _) Nothing = "no position" | ||
550 | showRange (Just src) (Just (Range s e)) = str | ||
551 | where | ||
552 | startLine = sourceLine s - 1 | ||
553 | endline = sourceLine e - if sourceColumn e == 1 then 1 else 0 | ||
554 | len = endline - startLine | ||
555 | str = vcat $ ("position:" <+> text (show s) <+> "-" <+> text (show e)): | ||
556 | map text (take len $ drop startLine $ lines src) | ||
557 | ++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1] | ||
558 | |||
559 | -------------------------------------------------------------------------------- parser output | ||
560 | |||
561 | data ValueDef p e = ValueDef Bool{-recursive-} p e | ||
562 | data TypeSig n t = TypeSig n t | ||
563 | |||
564 | data ModuleR | ||
565 | = Module | ||
566 | { extensions :: [Extension] | ||
567 | , moduleImports :: [Name] -- TODO | ||
568 | , moduleExports :: Maybe [Export] | ||
569 | , definitions :: [DefinitionR] | ||
570 | } | ||
571 | |||
572 | type DefinitionR = WithRange Definition | ||
573 | data Definition | ||
574 | = DValueDef Bool{-True: use in instance search-} (ValueDef PatR ExpR) | ||
575 | | DAxiom (TypeSig Name ExpR) | ||
576 | | DDataDef Name [(Name, ExpR)] [WithRange ConDef] -- TODO: remove, use GADT | ||
577 | | GADT Name [(Name, ExpR)] [WithRange (Name, ConDef')] | ||
578 | | ClassDef [ExpR] Name [(Name, ExpR)] [TypeSig Name ExpR] | ||
579 | | InstanceDef [ExpR] Name [ExpR] [ValueDef PatR ExpR] | ||
580 | | TypeFamilyDef Name [(Name, ExpR)] ExpR | ||
581 | | PrecDef Name Fixity | ||
582 | -- used only during parsing | ||
583 | | PreValueDef (Range, EName) [PatR] WhereRHS | ||
584 | | DTypeSig (TypeSig EName ExpR) | ||
585 | | ForeignDef Name ExpR | ||
586 | |||
587 | -- used only during parsing | ||
588 | data WhereRHS = WhereRHS GuardedRHS (Maybe WhereBlock) | ||
589 | type WhereBlock = [DefinitionR] | ||
590 | |||
591 | -- used only during parsing | ||
592 | data GuardedRHS | ||
593 | = Guards Range [(ExpR, ExpR)] | ||
594 | | NoGuards ExpR | ||
595 | |||
596 | data ConDef = ConDef Name [FieldTy] | ||
597 | data ConDef' = ConDef' [(Maybe Name, ExpR)] [FieldTy] ExpR | ||
598 | data FieldTy = FieldTy {fieldName :: Maybe (Name, Bool{-True: context projection-}), fieldType :: ExpR} | ||
599 | |||
600 | type TypeFunR = TypeFun Name ExpR | ||
601 | type ValueDefR = ValueDef PatR ExpR | ||
602 | |||
603 | data Extension | ||
604 | = NoImplicitPrelude | ||
605 | deriving (Eq, Ord, Show) | ||
606 | |||
607 | data Export | ||
608 | = ExportModule Name | ||
609 | | ExportId Name | ||
610 | |||
611 | -------------------------------------------------------------------------------- names with unique ids | ||
612 | |||
613 | type IdN = N | ||
614 | pattern IdN a = a | ||
615 | --newtype IdN = IdN N deriving (Eq, Ord) | ||
616 | {- TODO | ||
617 | data IdN = IdN !Int N | ||
618 | |||
619 | instance Eq IdN where IdN i _ == IdN j _ = i == j | ||
620 | instance Ord IdN where IdN i _ `compare` IdN j _ = i `compare` j | ||
621 | -} | ||
622 | |||
623 | pattern TypeIdN n <- IdN (TypeN n) | ||
624 | pattern TypeIdN' n i = IdN (TypeN' n i) | ||
625 | pattern ExpIdN n <- IdN (ExpN n) | ||
626 | pattern ExpIdN' n i = IdN (ExpN' n i) | ||
627 | |||
628 | type FreshVars = [String] -- fresh typevar names | ||
629 | |||
630 | type VarMT = StateT FreshVars | ||
631 | |||
632 | show5 :: Int -> String | ||
633 | show5 i = replicate (5 - length s) '0' ++ s where s = show i | ||
634 | |||
635 | freshTypeVars :: FreshVars | ||
636 | freshTypeVars = map ('t':) $ map show5 [0..] | ||
637 | |||
638 | resetVars :: MonadState FreshVars m => m () | ||
639 | resetVars = put freshTypeVars | ||
640 | |||
641 | newName :: MonadState FreshVars m => Doc -> m IdN | ||
642 | newName info = do | ||
643 | i <- gets head | ||
644 | modify tail | ||
645 | return $ TypeN' i info | ||
646 | |||
647 | newEName = do | ||
648 | i <- gets head | ||
649 | modify tail | ||
650 | return $ ExpN $ "e" ++ i | ||
651 | |||
652 | |||
653 | -------------------------------------------------------------------------------- environments | ||
654 | |||
655 | type Env' a = Map Name a | ||
656 | type Env a = Map IdN a | ||
657 | |||
658 | data Item = ISubst Bool{-True: found & replaced def-} Exp | ISig Bool{-True: Rigid-} Exp | ||
659 | |||
660 | tyOfItem = eitherItem (const tyOf) $ const id | ||
661 | |||
662 | eitherItem f g (ISubst r x) = f r x | ||
663 | eitherItem f g (ISig r x) = g r x | ||
664 | |||
665 | pureSubst se = null [x | ISig rigid x <- Map.elems $ getTEnv se] | ||
666 | onlySig (TEnv x) = TEnv $ Map.filter isSig x | ||
667 | isSig = eitherItem (\_ -> const False) (\rigid -> const True) | ||
668 | |||
669 | newtype Subst = Subst {getSubst :: Env Exp} | ||
670 | |||
671 | instance Monoid Subst where | ||
672 | mempty = Subst mempty | ||
673 | -- semantics: subst (m1 <> m2) = subst m1 . subst m2 | ||
674 | -- example: subst ({y -> z} <> {x -> y}) = subst {y -> z} . subst {x -> y} = subst {y -> z, x -> z} | ||
675 | -- example2: subst ({x -> z} <> {x -> y}) = subst {x -> z} . subst {x -> y} = subst {x -> y} | ||
676 | m1@(Subst y1) `mappend` Subst y2 = Subst $ (subst_ m1 <$> y2) <> y1 | ||
677 | |||
678 | subst_ = subst | ||
679 | singSubst' a b = Subst $ Map.singleton a b | ||
680 | |||
681 | nullSubst (Subst s) = Map.null s | ||
682 | toTEnv (Subst s) = TEnv $ ISubst False <$> s | ||
683 | toSubst (TEnv s) = Subst $ Map.map (\(ISubst _ e) -> e) $ Map.filter (eitherItem (\_ -> const True) (\_ -> const False)) s | ||
684 | |||
685 | newtype TEnv = TEnv {getTEnv :: Env Item} -- either substitution or bound name | ||
686 | |||
687 | instance Monoid TEnv where | ||
688 | mempty = TEnv mempty | ||
689 | -- semantics: apply (m1 <> m2) = apply m1 . apply m2 | ||
690 | -- example: subst ({y -> z} <> {x -> y}) = subst {y -> z} . subst {x -> y} = subst {y -> z, x -> z} | ||
691 | -- example2: subst ({x -> z} <> {x -> y}) = subst {x -> z} . subst {x -> y} = subst {x -> y} | ||
692 | m1@(TEnv y1) `mappend` TEnv y2 = TEnv $ Map.unionWith mergeSubsts (subst (toSubst m1) <$> y2) y1 | ||
693 | |||
694 | mergeSubsts (ISubst _ s) (ISig _ _) = ISubst True s | ||
695 | mergeSubsts (ISubst b s) (ISubst b' _) = ISubst (b || b') s | ||
696 | mergeSubsts (ISig _ _) (ISubst _ s) = ISubst True s | ||
697 | mergeSubsts a _ = a | ||
698 | |||
699 | singSubst a b = TEnv $ Map.singleton a $ ISubst False b | ||
700 | singSubstTy_ a b = TEnv $ Map.singleton a $ ISig False b | ||
701 | |||
702 | -- build recursive environment -- TODO: generalize | ||
703 | recEnv :: Pat -> Exp -> Exp | ||
704 | recEnv (PVar _ v) th_ = th where th = subst (singSubst' v th) th_ | ||
705 | recEnv _ th = th | ||
706 | |||
707 | mapExp' f nf pf e = mapExp_ nf pf $ f <$> e | ||
708 | |||
709 | peelThunkR :: Exp -> (Range, Exp') | ||
710 | peelThunkR e@(ExpTh r _ _) = (r, peelThunk e) | ||
711 | |||
712 | peelThunk :: Exp -> Exp' | ||
713 | peelThunk (ExpTh _ env@(Subst m) e) | ||
714 | -- | Map.null m = e | ||
715 | | otherwise = case e of | ||
716 | Forall_ h (Just n) a b -> Forall_ h (Just n) (f a) $ subst_ (delEnv n (f a) env) b | ||
717 | ELam_ h x y -> ELam_ (f <$> h) (mapPat' x) $ subst_ (delEnvs (patternVars x) env) y | ||
718 | Case_ t e cs -> Case_ (f t) (f e) [(mapPat' x, subst_ (delEnvs (patternVars x) env) y) | (x, y) <- cs] | ||
719 | ELet_ x y z -> ELet_ (mapPat' x) (g y) (g z) where | ||
720 | g = subst_ (delEnvs (patternVars x) env) | ||
721 | EVar_ k v -> case Map.lookup v m of | ||
722 | Just e -> case peelThunk e of | ||
723 | PrimFun _ a b c -> PrimFun (f k) a b c -- hack! | ||
724 | x -> x | ||
725 | _ -> EVar_ (f k) v | ||
726 | FunAlts_ i ts -> FunAlts_ i $ flip map ts $ \(p, t) -> (p, subst (delEnvs' (foldMap patternVars' p) env) t) | ||
727 | _ -> mapExp' f id (error "peelT") e | ||
728 | where | ||
729 | f = subst_ env | ||
730 | |||
731 | mapPat' :: Pat -> Pat | ||
732 | mapPat' (Pat p) = Pat $ mapPat f id id $ mapPat' <$> p | ||
733 | |||
734 | delEnv n x = delEnvs [(n, x)] | ||
735 | |||
736 | delEnvs xs (Subst env) = Subst $ foldr Map.delete env $ map fst xs | ||
737 | delEnvs' xs (Subst env) = Subst $ foldr Map.delete env xs | ||
738 | |||
739 | subst1 :: Subst -> Exp -> Exp | ||
740 | subst1 s@(Subst m) = \case | ||
741 | TVar k v -> case Map.lookup v m of | ||
742 | Just e -> subst1 s e | ||
743 | _ -> TVar k v | ||
744 | e -> e | ||
745 | |||
746 | -------------------------------------------------------------------------------- | ||
747 | -- fix :: forall (a :: *) . (a -> a) -> a | ||
748 | -- fix = \{a :: *} (f :: a -> a) -> [ x |-> f x ] x :: a | ||
749 | |||
750 | fixName = ExpN "fix" | ||
751 | |||
752 | fixBody :: Exp | ||
753 | fixBody = Exp $ ELam_ (Just ty) (PVar Star an) $ Exp $ ELam_ Nothing (PVar a fn) fx | ||
754 | where | ||
755 | ty = Exp $ Forall_ Hidden (Just an) Star $ (a ~> a) ~> a | ||
756 | |||
757 | fx = ExpTh mempty{-TODO: review this-} (singSubst' x $ TApp a f fx) $ EVar_ a x | ||
758 | |||
759 | an = TypeN "a" | ||
760 | a = TVar Star an | ||
761 | fn = ExpN "f" | ||
762 | f = TVar (a ~> a) fn | ||
763 | x = ExpN "x" | ||
764 | |||
765 | -------------------------------------------------------------------------------- | ||
766 | |||
767 | data PolyEnv = PolyEnv | ||
768 | { instanceDefs :: InstanceDefs | ||
769 | , getPolyEnv :: Env' Item | ||
770 | , constructors :: Env' [(Name, Int)] | ||
771 | , precedences :: PrecMap | ||
772 | , typeFamilies :: InstEnv | ||
773 | , infos :: Infos | ||
774 | } | ||
775 | |||
776 | type Info = (SourcePos, SourcePos, String) | ||
777 | type Infos = [Info] | ||
778 | |||
779 | type InstEnv = Env' Exp | ||
780 | |||
781 | type PrecMap = Env' Fixity | ||
782 | |||
783 | type InstanceDefs = Env' (Map Name ()) | ||
784 | |||
785 | emptyPolyEnv :: PolyEnv | ||
786 | emptyPolyEnv = PolyEnv mempty mempty mempty mempty mempty mempty | ||
787 | |||
788 | startPolyEnv = emptyPolyEnv {getPolyEnv = Map.singleton fixName $ ISubst True fixBody} | ||
789 | |||
790 | joinPolyEnvs :: forall m. MonadError ErrorMsg m => Bool -> [PolyEnv] -> m PolyEnv | ||
791 | joinPolyEnvs allownameshadow ps = PolyEnv | ||
792 | <$> mkJoin' instanceDefs | ||
793 | <*> mkJoin allownameshadow getPolyEnv | ||
794 | <*> mkJoin allownameshadow constructors | ||
795 | <*> mkJoin False precedences | ||
796 | <*> mkJoin False typeFamilies | ||
797 | <*> pure (concatMap infos ps) | ||
798 | where | ||
799 | mkJoin :: Bool -> (PolyEnv -> Env a) -> m (Env a) | ||
800 | mkJoin True f = return $ Map.unions $ map f ps | ||
801 | mkJoin False f = case filter (not . Map.null) . map f $ ps of | ||
802 | [m] -> return m | ||
803 | ms -> case filter (not . null . drop 1 . snd) $ Map.toList ms' of | ||
804 | [] -> return $ fmap head $ Map.filter (not . null) ms' | ||
805 | xs -> throwErrorTCM $ "Definition clash:" <+> pShow (map fst xs) | ||
806 | where | ||
807 | ms' = Map.unionsWith (++) $ map ((:[]) <$>) ms | ||
808 | |||
809 | mkJoin' f = case [(n, x) | (n, s) <- Map.toList ms', (x, is) <- Map.toList s, not $ null $ drop 1 is] of | ||
810 | _ -> return $ fmap head . Map.filter (not . null) <$> ms' | ||
811 | -- xs -> throwErrorTCM $ "Definition clash':" <+> pShow xs | ||
812 | where | ||
813 | ms' = Map.unionsWith (Map.unionWith (++)) $ map ((((:[]) <$>) <$>) . f) ps | ||
814 | |||
815 | addPolyEnv pe m = do | ||
816 | env <- ask | ||
817 | env <- joinPolyEnvs True [pe, env] | ||
818 | local (const env) m | ||
819 | |||
820 | -- reversed order! | ||
821 | getApp (Exp x) = case x of | ||
822 | EApp_ _ f x -> (id *** (x:)) <$> getApp f | ||
823 | TCon_ _ n -> Just (n, []) | ||
824 | _ -> Nothing | ||
825 | |||
826 | withTyping ts = addPolyEnv $ emptyPolyEnv {getPolyEnv = ISig False <$> ts} | ||
827 | |||
828 | -------------------------------------------------------------------------------- monads | ||
829 | |||
830 | nullTEnv (TEnv m) = Map.null m | ||
831 | |||
832 | type TypingT = WriterT' TEnv | ||
833 | |||
834 | type EnvType = (TEnv, Exp) | ||
835 | |||
836 | hidden = \case | ||
837 | Visible -> False | ||
838 | _ -> True | ||
839 | |||
840 | toEnvType :: Exp -> ([(Visibility, (Name, Exp))], Exp) | ||
841 | toEnvType = \case | ||
842 | Exp (Forall_ v@(hidden -> True) (Just n) t x) -> ((v, (n, t)):) *** id $ toEnvType x | ||
843 | x -> (mempty, x) | ||
844 | |||
845 | envType d = TEnv $ Map.fromList $ map ((id *** ISig False) . snd) d | ||
846 | |||
847 | addInstance n ((envType *** id) . toEnvType -> (_, getApp -> Just (c, _))) | ||
848 | = addPolyEnv $ emptyPolyEnv {instanceDefs = Map.singleton c $ Map.singleton n ()} | ||
849 | |||
850 | monoInstType v k = Map.singleton v k | ||
851 | |||
852 | toTCMS :: Exp -> TCMS ([Exp], Exp) | ||
853 | toTCMS (toEnvType -> (typ@(envType -> TEnv se), ty)) = WriterT' $ do | ||
854 | let fv = map (fst . snd) typ | ||
855 | newVars <- forM fv $ \case | ||
856 | TypeN' n i -> newName $ "instvar" <+> text n <+> i | ||
857 | v -> error $ "instT: " ++ ppShow v | ||
858 | let s = Map.fromList $ zip fv newVars | ||
859 | return (TEnv $ repl s se, (map (repl s . uncurry (flip TVar)) $ hiddenVars typ, repl s ty)) | ||
860 | |||
861 | hiddenVars ty = [x | (Hidden, x) <- ty] | ||
862 | |||
863 | instantiateTyping_ vis info se ty = do | ||
864 | ambiguityCheck ("ambcheck" <+> info) se ty --(subst su se) (subst su ty) | ||
865 | typingToTy_ vis ".." (se, ty) | ||
866 | where | ||
867 | su = toSubst se | ||
868 | |||
869 | splitEnv (TEnv se) = TEnv *** TEnv $ cycle (f gr') (se', gr') | ||
870 | where | ||
871 | (se', gr') = flip Map.partition se $ \case | ||
872 | ISubst False _ -> False | ||
873 | _ -> True | ||
874 | f = foldMap (\(k, ISubst False x) -> Set.insert k $ freeVars x) . Map.toList | ||
875 | f' = foldMap (\(k, ISig False x) -> Set.insert k $ freeVars x) . Map.toList | ||
876 | cycle acc (se, gr) = (if Set.null s then id else cycle (acc <> s)) (se', gr <> gr') | ||
877 | where | ||
878 | (se', gr') = flip Map.partitionWithKey se $ \k -> \case | ||
879 | ISig False t -> not $ Set.insert k (freeVars t) `hasSame` acc | ||
880 | _ -> True | ||
881 | s = f' gr' | ||
882 | |||
883 | hasSame a b = not $ Set.null $ a `Set.intersection` b | ||
884 | |||
885 | instantiateTyping_' :: Bool -> Doc -> TEnv -> Exp -> TCM ([(IdN, Exp)], Exp) | ||
886 | instantiateTyping_' typ info se ty = do | ||
887 | ty <- instantiateTyping_ (if typ then Hidden else Irrelevant) info se ty | ||
888 | return (hiddenVars $ fst $ toEnvType ty, ty) | ||
889 | |||
890 | -- Ambiguous: (Int ~ F a) => Int | ||
891 | -- Not ambiguous: (Show a, a ~ F b) => b | ||
892 | --ambiguityCheck :: Doc -> TCMS Exp -> TCMS Exp | ||
893 | ambiguityCheck msg se ty = do | ||
894 | pe <- asks getPolyEnv | ||
895 | let defined = dependentVars (Map.toList $ getTEnv se) $ Map.keysSet pe <> freeVars ty | ||
896 | case [(n, c) | (n, ISig rigid c) <- Map.toList $ getTEnv se, not $ any (`Set.member` defined) $ Set.insert n $ freeVars c] of | ||
897 | [] -> return () | ||
898 | err -> do | ||
899 | tt <- typingToTy' (se, ty) | ||
900 | throwErrorTCM $ | ||
901 | "during" <+> msg </> "ambiguous type:" <$$> pShow tt <$$> "problematic vars:" <+> pShow err | ||
902 | |||
903 | -- compute dependent type vars in constraints | ||
904 | -- Example: dependentVars [(a, b) ~ F b c, d ~ F e] [c] == [a,b,c] | ||
905 | dependentVars :: [(IdN, Item)] -> Set TName -> Set TName | ||
906 | dependentVars ie s = cycle mempty s | ||
907 | where | ||
908 | cycle acc s | ||
909 | | Set.null s = acc | ||
910 | | otherwise = cycle (acc <> s) (grow s Set.\\ acc) | ||
911 | |||
912 | grow = flip foldMap ie $ \case | ||
913 | (n, ISig rigid t) -> (Set.singleton n <-> freeVars t) <> case t of | ||
914 | CEq ty f -> freeVars ty <-> freeVars f | ||
915 | Split a b c -> freeVars a <-> (freeVars b <> freeVars c) | ||
916 | -- CUnify{} -> mempty --error "dependentVars: impossible" | ||
917 | _ -> mempty | ||
918 | -- (n, ISubst False x) -> (Set.singleton n <-> freeVars x) | ||
919 | _ -> mempty | ||
920 | where | ||
921 | a --> b = \s -> if Set.null $ a `Set.intersection` s then mempty else b | ||
922 | a <-> b = (a --> b) <> (b --> a) | ||
923 | |||
924 | --typingToTy' :: EnvType -> Exp | ||
925 | typingToTy' (s, t) = typingToTy "typingToTy" s t | ||
926 | |||
927 | --typingToTy :: Doc -> TEnv -> Exp -> Exp | ||
928 | typingToTy msg env ty = removeStar . renameVars <$> typingToTy_ Hidden msg (env, ty) | ||
929 | where | ||
930 | removeStar (Exp (Forall_ (hidden -> True) _ Star t)) = removeStar t | ||
931 | removeStar t = t | ||
932 | |||
933 | renameVars :: Exp -> Exp | ||
934 | renameVars = flip evalState (map (:[]) ['a'..]) . f mempty | ||
935 | where | ||
936 | f m (Exp e) = Exp <$> case e of | ||
937 | Forall_ h (Just n) k e -> do | ||
938 | n' <- gets (TypeN . head) | ||
939 | modify tail | ||
940 | Forall_ h (Just n') <$> f m k <*> f (Map.insert n n' m) e | ||
941 | e -> traverseExp nf (f m) e | ||
942 | where | ||
943 | nf n = fromMaybe n $ Map.lookup n m | ||
944 | |||
945 | --typingToTy_ :: Visibility -> Doc -> EnvType -> Exp | ||
946 | typingToTy_ vs msg (env, ty) = do | ||
947 | pe <- asks getPolyEnv | ||
948 | return $ f (Map.keysSet pe) l | ||
949 | where | ||
950 | l = sortBy (compare `on` constrKind . snd) [(n, t) | (n, ISig rigid t) <- Map.toList $ getTEnv env] | ||
951 | forall_ n k t | ||
952 | -- | n `Set.notMember` freeVars t = TArrH k t | ||
953 | | otherwise = Exp $ Forall_ vs (Just n) k t | ||
954 | |||
955 | constrKind = \case | ||
956 | Star -> 0 | ||
957 | _ -> 2 | ||
958 | |||
959 | -- TODO: make more efficient? | ||
960 | f s [] = ty | ||
961 | f s ts = case [x | x@((n, t), ts') <- getOne ts, let fv = freeVars t, fv `Set.isSubsetOf` s] of | ||
962 | (((n, t), ts): _) -> forall_ n t $ f (Set.insert n s) ts | ||
963 | _ -> error $ show $ "orderEnv:" <+> msg <$$> pShow ts <$$> pShow l <$$> pShow ty | ||
964 | |||
965 | getOne xs = [(b, a ++ c) | (a, b: c) <- zip (inits xs) (tails xs)] | ||
966 | |||
967 | instance PShow Subst where | ||
968 | pShowPrec p (Subst t) = "Subst" <+> pShow t | ||
969 | |||
970 | -- type checking monad transformer | ||
971 | type TCMT m = ReaderT PolyEnv (ErrorT (WriterT Infos (VarMT m))) | ||
972 | |||
973 | type TCM = TCMT Identity | ||
974 | |||
975 | type TCMS = TypingT TCM | ||
976 | |||
977 | catchExc :: TCM a -> TCM (Maybe a) | ||
978 | catchExc = mapReaderT $ lift . fmap (either (const Nothing) Just) . runExceptT | ||
979 | |||
980 | -------------------------------------------------------------------------------- free variables | ||
981 | |||
982 | class FreeVars a where freeVars :: a -> Set IdN | ||
983 | |||
984 | instance FreeVars Exp where | ||
985 | freeVars = \case | ||
986 | Exp x -> case x of | ||
987 | ELam_ h x y -> freeVars y Set.\\ Set.fromList (map fst $ patternVars x) -- TODO: h? | ||
988 | Case_ t e cs -> freeVars t <> freeVars e <> foldMap (\(x, y) -> freeVars y Set.\\ Set.fromList (map fst $ patternVars x)) cs | ||
989 | ELet_ x y z -> (freeVars y <> freeVars z) Set.\\ Set.fromList (map fst $ patternVars x) -- TODO: revise | ||
990 | EVar_ k a -> Set.singleton a <> freeVars k | ||
991 | Forall_ h (Just v) k t -> freeVars k <> Set.delete v (freeVars t) | ||
992 | x -> foldMap freeVars x | ||
993 | |||
994 | instance FreeVars a => FreeVars [a] where freeVars = foldMap freeVars | ||
995 | instance FreeVars a => FreeVars (TypeFun n a) where freeVars = foldMap freeVars | ||
996 | instance FreeVars a => FreeVars (Env a) where freeVars = foldMap freeVars | ||
997 | |||
998 | -------------------------------------------------------------------------------- replacement | ||
999 | |||
1000 | type Repl = Map IdN IdN | ||
1001 | |||
1002 | -- TODO: express with Substitute? | ||
1003 | class Replace a where repl :: Repl -> a -> a | ||
1004 | |||
1005 | -- TODO: make more efficient | ||
1006 | instance Replace Exp where | ||
1007 | repl st = \case | ||
1008 | ty | Map.null st -> ty -- optimization | ||
1009 | Exp s -> Exp $ case s of | ||
1010 | ELam_ h _ _ -> error "repl lam" | ||
1011 | Case_ _ _ _ -> error "repl case" | ||
1012 | ELet_ _ _ _ -> error "repl let" | ||
1013 | Forall_ h (Just n) a b -> Forall_ h (Just n) (f a) (repl (Map.delete n st) b) | ||
1014 | t -> mapExp' f rn (error "repl") t | ||
1015 | where | ||
1016 | f = repl st | ||
1017 | rn a | ||
1018 | | Just t <- Map.lookup a st = t | ||
1019 | | otherwise = a | ||
1020 | |||
1021 | instance Replace a => Replace (Env a) where | ||
1022 | repl st e = Map.fromList $ map (r *** repl st) $ Map.toList e | ||
1023 | where | ||
1024 | r x = fromMaybe x $ Map.lookup x st | ||
1025 | |||
1026 | instance (Replace a, Replace b) => Replace (Either a b) where | ||
1027 | repl st = either (Left . repl st) (Right . repl st) | ||
1028 | instance Replace Item where | ||
1029 | repl st = eitherItem (\r -> ISubst r . repl st) (\r -> ISig r . repl st) | ||
1030 | |||
1031 | -------------------------------------------------------------------------------- substitution | ||
1032 | |||
1033 | -- TODO: review usage (use only after unification) | ||
1034 | class Substitute x a where subst :: x -> a -> a | ||
1035 | |||
1036 | --instance Substitute a => Substitute (Constraint' n a) where subst = fmap . subst | ||
1037 | instance Substitute x a => Substitute x [a] where subst = fmap . subst | ||
1038 | instance (Substitute x a, Substitute x b) => Substitute x (a, b) where subst s (a, b) = (subst s a, subst s b) | ||
1039 | instance (Substitute x a, Substitute x b) => Substitute x (Either a b) where subst s = subst s +++ subst s | ||
1040 | instance Substitute x Exp => Substitute x Item where subst s = eitherItem (\r -> ISubst r . subst s) (\r -> ISig r . subst s) | ||
1041 | {- | ||
1042 | instance Substitute Pat where | ||
1043 | subst s = \case | ||
1044 | PVar t v -> PVar $ subst s v | ||
1045 | PCon t n l -> PCon (VarE n $ subst s ty) $ subst s l | ||
1046 | Pat p -> Pat $ subst s <$> p | ||
1047 | -} | ||
1048 | --instance Substitute TEnv Exp where subst = subst . toSubst --m1 (ExpTh m exp) = ExpTh (toSubst m1 <> m) exp | ||
1049 | instance Substitute Subst Exp where subst m1 (ExpTh r m exp) = ExpTh r (m1 <> m) exp | ||
1050 | --instance Substitute TEnv TEnv where subst s (TEnv m) = TEnv $ subst s <$> m | ||
1051 | instance Substitute Subst TEnv where subst s (TEnv m) = TEnv $ subst s <$> m | ||
1052 | {- | ||
1053 | instance Substitute Subst (Pat' Exp) where | ||
1054 | subst s = \case | ||
1055 | = PatVar v ->Name -- v | ||
1056 | | PatCon ConName [ParPat e] | ||
1057 | | PatLit Lit | ||
1058 | | ViewPat e (ParPat e) | ||
1059 | | PatPrec (ParPat e) [(ParPat e{-TODO-}, ParPat e)] -- used before precedence calculation | ||
1060 | x -> fmap (subst s) x | ||
1061 | -} | ||
1062 | instance Substitute Subst (GuardTree Exp) where | ||
1063 | subst s = \case | ||
1064 | GuardPat e p t -> GuardPat e p $ subst (delEnvs' (patternVars' p) s) t | ||
1065 | GuardCon e n ps t -> GuardCon e n ps $ subst (delEnvs' (foldMap patternVars' ps) s) t | ||
1066 | GuardWhere bs t -> GuardWhere (map (id *** subst s') bs) $ subst s' t | ||
1067 | where s' = delEnvs (foldMap patternVars $ map fst bs) s | ||
1068 | x -> fmap (subst s) x | ||
1069 | |||
1070 | -------------------------------------------------------------------------------- LambdaCube specific definitions | ||
1071 | -- TODO: eliminate most of these | ||
1072 | pattern StarStar = TArr Star Star | ||
1073 | |||
1074 | pattern TCon0 a = TCon Star a | ||
1075 | pattern TCon1 a b = TApp Star (TCon StarStar a) b | ||
1076 | pattern TCon2 a b c = TApp Star (TApp StarStar (TCon (TArr Star StarStar) a) b) c | ||
1077 | pattern TCon2' a b c = TApp Star (TApp StarStar (TCon VecKind a) b) c | ||
1078 | pattern TCon3' a b c d = TApp Star (TApp StarStar (TApp VecKind (TCon (TArr Star VecKind) a) b) c) d | ||
1079 | |||
1080 | pattern TVec a b = TCon2' "Vec" (ENat a) b | ||
1081 | pattern TMat a b c = TApp Star (TApp StarStar (TApp VecKind (TCon MatKind "Mat") (ENat a)) (ENat b)) c | ||
1082 | pattern TSingRecord x t <- TRecord (singletonView -> Just (x, t)) | ||
1083 | singletonView m = case Map.toList m of | ||
1084 | [a] -> Just a | ||
1085 | _ -> Nothing | ||
1086 | |||
1087 | -- basic types | ||
1088 | pattern TChar = TCon0 "Char" | ||
1089 | pattern TString = TCon0 "String" | ||
1090 | pattern TBool = TCon0 "Bool" | ||
1091 | pattern TOrdering = TCon0 "Ordering" | ||
1092 | pattern TWord = TCon0 "Word" | ||
1093 | pattern TInt = TCon0 "Int" | ||
1094 | pattern TNat = TCon0 "Nat" | ||
1095 | pattern TFloat = TCon0 "Float" | ||
1096 | pattern VecKind = TArr TNat StarStar | ||
1097 | pattern MatKind = TArr TNat (TArr TNat StarStar) | ||
1098 | pattern TList a = TCon1 "List" a | ||
1099 | |||
1100 | pattern Ordering = TCon0 "Ordering" | ||
1101 | |||
1102 | -- Semantic | ||
1103 | pattern Depth a = TCon1 "Depth" a | ||
1104 | pattern Stencil a = TCon1 "Stencil" a | ||
1105 | pattern Color a = TCon1 "Color" a | ||
1106 | |||
1107 | -- GADT | ||
1108 | pattern TFragmentOperation b = TCon1 "FragmentOperation" b | ||
1109 | pattern TImage b c = TCon2' "Image" b c | ||
1110 | pattern TInterpolated b = TCon1 "Interpolated" b | ||
1111 | pattern TFrameBuffer b c = TCon2' "FrameBuffer" b c | ||
1112 | pattern TSampler = TCon0 "Sampler" | ||
1113 | |||
1114 | pattern ClassN n <- TypeN n where | ||
1115 | ClassN n = TypeN' n "class" | ||
1116 | pattern IsValidOutput = ClassN "ValidOutput" | ||
1117 | pattern IsTypeLevelNatural = ClassN "TNat" | ||
1118 | pattern IsValidFrameBuffer = ClassN "ValidFrameBuffer" | ||
1119 | pattern IsAttributeTuple = ClassN "AttributeTuple" | ||
1120 | |||
1121 | pattern TypeFunS a b <- TypeFun (TypeN a) b where | ||
1122 | TypeFunS a b = TypeFun (TypeN' a "typefun") b | ||
1123 | pattern TFMat a b = TypeFunS "TFMat" [a, b] -- may be data family | ||
1124 | pattern TFVec a b = TypeFunS "TFVec" [a, b] -- may be data family | ||
1125 | pattern TFMatVecElem a = TypeFunS "MatVecElem" [a] | ||
1126 | pattern TFMatVecScalarElem a = TypeFunS "MatVecScalarElem" [a] | ||
1127 | pattern TFVecScalar a b = TypeFunS "VecScalar" [a, b] | ||
1128 | pattern TFFTRepr' a = TypeFunS "FTRepr'" [a] | ||
1129 | pattern TFColorRepr a = TypeFunS "ColorRepr" [a] | ||
1130 | pattern TFFrameBuffer a = TypeFunS "TFFrameBuffer" [a] | ||
1131 | pattern TFFragOps a = TypeFunS "FragOps" [a] | ||
1132 | pattern TFJoinTupleType a b = TypeFunS "JoinTupleType" [a, b] | ||
1133 | |||
1134 | -------------------------------------------------------------------------------- | ||
1135 | -- reducer implemented following | ||
1136 | -- "A Tutorial Implementation of a Dependently Typed Lambda Calculus" | ||
1137 | -- Andres Löh, Conor McBride and Wouter Swierstra following | ||
1138 | |||
1139 | reduceNew :: Exp -> Exp | ||
1140 | reduceNew e = quote (tyOf e) 0 $ eEval mempty e mempty | ||
1141 | |||
1142 | vQuote = VNeutral . NGlobal | ||
1143 | qname i = ExpN $ "quote" ++ show i | ||
1144 | |||
1145 | quote :: Exp -> Int -> Value -> Exp | ||
1146 | quote ty ii VStar = Star | ||
1147 | quote ty ii (VLit i) = ELit i | ||
1148 | quote ty ii (VCCon t (TupleName _) vs) = ETuple $ zipWith (\ty x -> quote ty ii x) (tupleTypes vs t) vs | ||
1149 | quote ty ii val@(VCCon t (ConName n) vs) = mkApp t (Exp $ EVar_ t n) vs | ||
1150 | where | ||
1151 | mkApp t@(Exp (Forall_ _ _ a b)) e (x:xs) = mkApp b (Exp $ EApp_ b e $ quote a ii x) xs | ||
1152 | mkApp t e [] = e | ||
1153 | mkApp a b c = error $ "mkApp: " ++ ppShow t ++ "; " ++ show val | ||
1154 | quote ty ii (VLam_ t) = Exp $ ELam_ Nothing (PVar a n) $ quote b (ii + 1) $ t $ vQuote n where | ||
1155 | n = qname ii | ||
1156 | (a, b) = case ty of | ||
1157 | Exp (Forall_ _ _ a b) -> (a, b) | ||
1158 | TWildcard -> (TWildcard, TWildcard) | ||
1159 | _ -> error $ "quote: " ++ ppShow ty | ||
1160 | quote ty ii (VPi v f) | ||
1161 | = error $ "quote: " ++ "2" | ||
1162 | quote ty ii (VNeutral n) = neutralQuote ty ii n | ||
1163 | |||
1164 | neutralQuote :: Exp -> Int -> Neutral -> Exp | ||
1165 | neutralQuote ty ii (NGlobal v) = Exp $ EVar_ ty v | ||
1166 | neutralQuote ty ii (NQuote k) | ||
1167 | = error $ "nquote: " ++ "3" | ||
1168 | neutralQuote ty ii (NApp_ n v) | ||
1169 | = error $ "nquote: " ++ "4" | ||
1170 | neutralQuote ty ii (NCase ts x) | ||
1171 | = error $ "nquote: " ++ "5" | ||
1172 | neutralQuote ty ii val@(NPrim t n vs) = Exp $ PrimFun ty n (mkApp t vs) 0 | ||
1173 | where | ||
1174 | mkApp t@(Exp (Forall_ _ _ a b)) (x:xs) = quote a ii x: mkApp b xs | ||
1175 | mkApp t [] = [] | ||
1176 | mkApp a c = error $ "mkApp2: " ++ ppShow t ++ "; " ++ show val | ||
1177 | |||
1178 | arity :: Exp -> Int | ||
1179 | arity (Exp a) = {-trace (ppShow a) $ -} case a of | ||
1180 | Forall_ Visible _ _ b -> 1 + arity b | ||
1181 | Forall_ Hidden _ _ b -> 1 + arity b | ||
1182 | Forall_ Irrelevant _ _ b -> error "arity" --0 + arity b | ||
1183 | _ -> 0 | ||
1184 | |||
1185 | primType ty l = foldr (~>) ty $ map tyOf l | ||
1186 | tupleType es = foldr (~>) (tyOf $ ETuple es) $ map tyOf es | ||
1187 | tupleTypes xs t = f xs t where | ||
1188 | f (_: xs) (Exp (Forall_ _ _ a b)) = a: f xs b | ||
1189 | f [] (TTuple _) = [] | ||
1190 | f _ _ = error $ "tupleTypes: " ++ ppShow (xs, t) | ||
1191 | |||
1192 | eEval :: [Name] -> Exp -> Env_ -> Value | ||
1193 | eEval ne (Exp e) = case e of | ||
1194 | Star_ -> const VStar | ||
1195 | ELit_ l -> const $ VLit l | ||
1196 | EVar_ t v | isConstr v -> -- trace (show i ++ " " ++ ppShow v ++ " :: " ++ ppShow t) $ | ||
1197 | \d -> ff i id | ||
1198 | where | ||
1199 | i = arity t | ||
1200 | ff :: Int -> ([Value] -> [Value]) -> Value | ||
1201 | ff 0 acc = {- trace (ppShow (v, t)) $ -} VCCon t (ConName v) (acc []) | ||
1202 | ff i acc = VLam_ $ \x -> ff (i-1) (acc . (x:)) | ||
1203 | EVar_ _ v -> \d -> maybe (VNeutral $ NGlobal v) (d !!) $ findIndex (== v) ne | ||
1204 | TCon_ b v | ||
1205 | -> error $ "eEval" ++ "3" | ||
1206 | TWildcard_ | ||
1207 | -> error $ "eEval" ++ "4" | ||
1208 | Forall_ v m a b-- Visibility (Maybe v) b b | ||
1209 | -> error $ "eEval" ++ "5" | ||
1210 | ELam_ _ (PVar _ n) b -> \d -> VLam_ (eEval (n: ne) b . (: d)) | ||
1211 | ELam_ ty p b -> eEval ne $ Exp $ ELam_ ty (PVar (tyOfPat p) n) $ Case (tyOf b) (Exp $ EVar_ (tyOfPat p) n) [(p, b)] | ||
1212 | where n = ExpN "lamvar" | ||
1213 | EApp_ _ f x -> \d -> vapp_ (eEval ne f d) (eEval ne x d) | ||
1214 | ETyApp_ a b c-- b b b | ||
1215 | -> error $ "eEval" ++ "8" | ||
1216 | EPrec_ _ _ -- b [(b, b)] -- aux: used only before precedence calculation | ||
1217 | -> error $ "eEval" ++ "9" | ||
1218 | ELet_ p a b -> eEval ne $ Exp $ EApp_ (tyOf b) (Exp $ ELam_ Nothing p b) a -- TODO | ||
1219 | TRecord_ m -- (Map v b) | ||
1220 | -> error $ "eEval" ++ "11" | ||
1221 | ERecord_ l -- [(Name, b)] | ||
1222 | -> error $ "eEval" ++ "12" | ||
1223 | EFieldProj_ b n --b Name | ||
1224 | -> error $ "eEval" ++ "13" | ||
1225 | TTuple_ l -- [b] | ||
1226 | -> error $ "eEval" ++ "14" | ||
1227 | ETuple_ l -> \d -> VCCon (tupleType l) (TupleName $ length l) $ map ($ d) $ map (eEval ne) l | ||
1228 | ENamedRecord_ n l --Name [(Name, b)] | ||
1229 | -> error $ "eEval" ++ "16" | ||
1230 | WRefl_ b | ||
1231 | -> error $ "eEval" ++ "17" | ||
1232 | CEq_ b t -- b (TypeFun v b) | ||
1233 | -> error $ "eEval" ++ "18" | ||
1234 | CUnify_ a b-- b b | ||
1235 | -> error $ "eEval" ++ "19" | ||
1236 | Split_ a b c-- b b b | ||
1237 | -> error $ "eEval" ++ "20" | ||
1238 | ETypeSig_ a b --b b | ||
1239 | -> error $ "eEval" ++ "21" | ||
1240 | Case_ _ a l -> {-traceShow (length l) $ -} let | ||
1241 | l' = map ff l | ||
1242 | ne' ps = reverse (map fst $ foldMap patternVars ps) ++ ne | ||
1243 | ff (PCon _ c ps, x) = (ConName c, foldr llam (eEval (ne' ps) x) ps) | ||
1244 | ff (PTuple ps, x) = (TupleName $ length ps, foldr llam (eEval (reverse [n | PVar _ n <- ps] ++ ne) x) ps) | ||
1245 | in \d -> case eEval ne a d of | ||
1246 | VCCon _ con' args -> head [foldl vapp_ (x d) args | (c, x) <- l', c == con'] | ||
1247 | VNeutral n -> VNeutral $ NCase (map (id *** ($ d)) l') n | ||
1248 | x -> error $ "eEval case: " ++ ppShow x | ||
1249 | where | ||
1250 | llam :: PatR -> (Env_ -> Value) -> Env_ -> Value | ||
1251 | llam (PVar _ n) e = \d -> VLam_ (e . (: d)) | ||
1252 | llam (Wildcard _) e = e | ||
1253 | llam p e = error $ "llam: " ++ ppShow p | ||
1254 | |||
1255 | |||
1256 | WhereBlock_ l a-- [(Name{-v-}, b)] b | ||
1257 | -> error $ "eEval" ++ "23" | ||
1258 | PrimFun ty n@(ExpN s) l i -> \d -> ff i id d | ||
1259 | where | ||
1260 | l' = map (eEval ne) l | ||
1261 | ff :: Int -> ([Value] -> [Value]) -> Env_ -> Value | ||
1262 | ff 0 acc d = f s ({-reverse ??? -} (map ($ d) l') ++ acc []) | ||
1263 | ff i acc d = VLam_ $ \x -> ff (i-1) (acc . (x:)) d | ||
1264 | |||
1265 | f "primIntToFloat" [VInt i] = VFloat $ fromIntegral i | ||
1266 | f "primNegateFloat" [VFloat i] = VFloat $ negate i | ||
1267 | f "PrimSin" [VFloat i] = VFloat $ sin i | ||
1268 | f "PrimCos" [VFloat i] = VFloat $ cos i | ||
1269 | f "PrimExp" [VFloat i] = VFloat $ exp i | ||
1270 | f "PrimLog" [VFloat i] = VFloat $ log i | ||
1271 | f "PrimAbs" [VFloat i] = VFloat $ abs i | ||
1272 | f "PrimAddS" [VFloat i, VFloat j] = VFloat $ i + j | ||
1273 | f "PrimSubS" [VFloat i, VFloat j] = VFloat $ i - j | ||
1274 | f "PrimAddS" [VInt i, VInt j] = VInt $ i + j | ||
1275 | f "PrimSubS" [VInt i, VInt j] = VInt $ i - j | ||
1276 | f "PrimMulS" [VFloat i, VFloat j] = VFloat $ i * j | ||
1277 | f "PrimDivS" [VFloat i, VFloat j] = VFloat $ i / j | ||
1278 | f "PrimModS" [VInt i, VInt j] = VInt $ i `mod` j | ||
1279 | f "PrimSqrt" [VInt i] = VInt $ round $ sqrt $ fromInteger i | ||
1280 | f "PrimIfThenElse" [VTrue,t,_] = t | ||
1281 | f "PrimIfThenElse" [VFalse,_,e] = e | ||
1282 | f "PrimGreaterThan" [VFloat i, VFloat j] = vBool $ i > j | ||
1283 | f "primCompareInt" [VInt i,VInt j] = VOrdering (show $ compare i j) | ||
1284 | f "primCompareNat" [VNat i,VNat j] = VOrdering (show $ compare i j) | ||
1285 | f "primCompareFloat" [VFloat i,VFloat j] = VOrdering (show $ compare i j) | ||
1286 | f "primCompareString" [VString i,VString j] = VOrdering (show $ compare i j) | ||
1287 | |||
1288 | f s xs = VNeutral $ NPrim (primType ty l) n xs | ||
1289 | |||
1290 | FunAlts_ i l -- Int{-number of parameters-} [([ParPat b], GuardTree b)] | ||
1291 | -> error $ "eEval" ++ "25" | ||
1292 | -- TODO: remove | ||
1293 | EAlts_ l -- [b] -- function alternatives | ||
1294 | -> error $ "eEval" ++ "26" | ||
1295 | ENext_ d b --Doc b -- go to next alternative | ||
1296 | -> error $ "eEval" ++ "27" | ||
1297 | |||
1298 | -------------------------------------------------------------------------------- | ||
1299 | |||
1300 | data Value | ||
1301 | = VLam_ (Value -> Value) | ||
1302 | | VPi Value (Value -> Value) | ||
1303 | | VStar | ||
1304 | | VCCon Exp{-constructor type-} ConName [Value] | ||
1305 | -- | VCon IConName [Value] -- not used | ||
1306 | | VLit !Lit | ||
1307 | | VNeutral Neutral | ||
1308 | |||
1309 | data Neutral | ||
1310 | = NGlobal Name | ||
1311 | | NLocal Int -- not used.. | ||
1312 | | NQuote Int -- not used.. -- TODO | ||
1313 | | NApp_ Neutral Value | ||
1314 | | NCase [(ConName, Value)] Neutral | ||
1315 | | NPrim Exp PrimName [Value] | ||
1316 | |||
1317 | type Env_ = [Value] | ||
1318 | type NameEnv v = Map.Map N v | ||
1319 | |||
1320 | type PrimName = N | ||
1321 | |||
1322 | pattern VInt i = VLit (LInt i) | ||
1323 | pattern VNat i = VLit (LNat i) | ||
1324 | pattern VFloat i = VLit (LFloat i) | ||
1325 | pattern VString i = VLit (LString i) | ||
1326 | pattern VFalse = VCCon TBool (ConName (ExpN "False")) [] | ||
1327 | pattern VTrue = VCCon TBool (ConName (ExpN "True")) [] | ||
1328 | pattern VOrdering s = VCCon TOrdering (ConName (ExpN s)) [] | ||
1329 | |||
1330 | vBool False = VFalse | ||
1331 | vBool True = VTrue | ||
1332 | |||
1333 | vapp_ :: Value -> Value -> Value | ||
1334 | vapp_ (VLam_ f) v = f v | ||
1335 | vapp_ (VNeutral n) v = VNeutral (NApp_ n v) | ||
1336 | |||
1337 | ---------------------- TODO: remove | ||
1338 | |||
1339 | instance Show Lit where show = ppShow | ||
1340 | instance Show PatR where show = ppShow | ||
1341 | |||
1342 | instance PShow Value where | ||
1343 | pShowPrec p = pShowPrec p . quote TWildcard 0 | ||
1344 | |||
1345 | instance Show Value where | ||
1346 | show = ppShow . quote TWildcard 0 | ||
1347 | instance Show Neutral where | ||
1348 | show = show . VNeutral | ||
1349 | |||
1350 | instance Show N where show = ppShow | ||
1351 | |||
1352 | -------------------------------------------------------------------------------- | ||
1353 | |||
1354 | type ReduceM = ExceptT String (State Int) | ||
1355 | |||
1356 | isNext (Exp a) = case a of | ||
1357 | ENext_ _ _ -> Nothing | ||
1358 | e -> Just $ Exp e | ||
1359 | |||
1360 | e &. f = maybe e f $ isNext e | ||
1361 | e >>=. f = isNext e >>= f | ||
1362 | |||
1363 | msum' (x: xs) = fromMaybe (msum' xs) $ isNext x | ||
1364 | msum' _ = error "pattern match failure." | ||
1365 | |||
1366 | reduceFail' msg = Nothing | ||
1367 | |||
1368 | -- full reduction | ||
1369 | -- TODO! reduction under lambda needs alpha-conversion! | ||
1370 | reduce :: Exp -> Exp | ||
1371 | reduce = reduce_ False | ||
1372 | reduce_ lam e = reduceHNF_ lam e & \(Exp e) -> Exp $ case e of | ||
1373 | -- ELam_ _ (PVar _ n) (EApp (Exp f) (EVar n')) | n == n' && n `Set.notMember` freeVars (Exp f) -> f | ||
1374 | ELam_ a b c -> ELam_ (reduce_ lam <$> a) b (reduce_ True c) | ||
1375 | -- ELet_ p x e -> ELet_ p x e | ||
1376 | -- Forall_ a b c d -> Forall_ a b (reduce_ lam c) (reduce_ True d) | ||
1377 | e -> reduce_ lam <$> e | ||
1378 | |||
1379 | -- don't reduce under lambda | ||
1380 | reduce' :: Exp -> Exp | ||
1381 | reduce' e = reduceHNF e & \(Exp e) -> case e of | ||
1382 | ELam_ _ _ _ -> Exp e | ||
1383 | Forall_ a b c d -> Exp e -- TODO: reduce c? | ||
1384 | _ -> Exp $ reduce' <$> e | ||
1385 | |||
1386 | reduceHNF :: Exp -> Exp -- Left: pattern match failure | ||
1387 | reduceHNF = reduceHNF_ False | ||
1388 | |||
1389 | isSTy = \case | ||
1390 | {- | ||
1391 | TInt -> True | ||
1392 | TBool -> True | ||
1393 | TFloat -> True | ||
1394 | TVec n t -> n `elem` [2,3,4] && t `elem` [TFloat, TBool, TInt] | ||
1395 | TMat n m TFloat -> n `elem` [2,3,4] && n == m | ||
1396 | -} | ||
1397 | _ -> False | ||
1398 | |||
1399 | reduceHNF_ lam (Exp exp) = case exp of | ||
1400 | |||
1401 | ELet_ p x e | ||
1402 | | lam && isSTy (tyOf x) -> keep | ||
1403 | | otherwise -> reduceHNF $ TApp (tyOf e) (ELam p e) x | ||
1404 | |||
1405 | PrimFun k (ExpN f) acc 0 -> evalPrimFun keep id k f $ map reduceHNF (reverse acc) | ||
1406 | |||
1407 | EAlts_ (map reduceHNF -> es) -> msum' $ es ++ error ("pattern match failure: " ++ ppShow es) | ||
1408 | EApp_ _ f x -> reduceHNF f &. \(Exp f) -> case f of | ||
1409 | |||
1410 | PrimFun (TArr _ k) f acc i | ||
1411 | | i > 0 -> reduceHNF $ Exp $ PrimFun k f (x: acc) (i-1) | ||
1412 | -- | otherwise -> error $ "too much argument for primfun " ++ ppShow f ++ ": " ++ ppShow exp | ||
1413 | |||
1414 | EFieldProj_ _ fi -> reduceHNF x &. \case | ||
1415 | ERecord fs -> case [e | (fi', e) <- fs, fi' == fi] of | ||
1416 | [e] -> reduceHNF e | ||
1417 | e -> case fi of | ||
1418 | ExpN "x" -> case e of | ||
1419 | A4 "V4" x y z w -> x | ||
1420 | A3 "V3" x y z -> x | ||
1421 | A2 "V2" x y -> x | ||
1422 | _ -> keep | ||
1423 | ExpN "y" -> case e of | ||
1424 | A4 "V4" x y z w -> y | ||
1425 | A3 "V3" x y z -> y | ||
1426 | A2 "V2" x y -> y | ||
1427 | _ -> keep | ||
1428 | ExpN "z" -> case e of | ||
1429 | A4 "V4" x y z w -> z | ||
1430 | A3 "V3" x y z -> z | ||
1431 | _ -> keep | ||
1432 | ExpN "w" -> case e of | ||
1433 | A4 "V4" x y z w -> w | ||
1434 | _ -> keep | ||
1435 | _ -> keep | ||
1436 | |||
1437 | ELam_ _ p e -> bind' (pShow (p, getTag e)) (matchPattern (reduce' x) p) $ \case | ||
1438 | Just m' -> reduceHNF $ subst m' e | ||
1439 | _ -> keep | ||
1440 | _ -> keep | ||
1441 | _ -> keep | ||
1442 | where | ||
1443 | reduceHNF = reduceHNF_ lam | ||
1444 | |||
1445 | keep = Exp exp | ||
1446 | |||
1447 | bind' err e f = maybe (Exp $ ENext_ err $ tyOf keep) f e | ||
1448 | |||
1449 | -- TODO: make this more efficient (memoize reduced expressions) | ||
1450 | matchPattern :: Exp -> Pat -> Maybe (Maybe Subst) -- Left: pattern match failure; Right Nothing: can't reduce | ||
1451 | matchPattern e = \case | ||
1452 | Wildcard _ -> return $ Just mempty | ||
1453 | PLit l -> e >>=. \case | ||
1454 | ELit l' | ||
1455 | | l == l' -> return $ Just mempty | ||
1456 | | otherwise -> reduceFail' $ "literals doesn't match:" <+> pShow (l, l') | ||
1457 | _ -> return Nothing | ||
1458 | PVar _ v -> return $ Just $ singSubst' v e | ||
1459 | PTuple ps -> e >>=. \e -> case e of | ||
1460 | ETuple xs -> fmap mconcat . sequence <$> sequence (zipWith matchPattern xs ps) | ||
1461 | _ -> return Nothing | ||
1462 | PCon t c ps -> getApp [] e >>= \case | ||
1463 | Just (c', xs) | ||
1464 | | c == c' && length xs == length ps -> fmap mconcat . sequence <$> sequence (zipWith matchPattern xs ps) | ||
1465 | | otherwise -> reduceFail' $ "constructors doesn't match:" <+> pShow (c, c') | ||
1466 | _ -> return Nothing | ||
1467 | p -> error $ "matchPattern: " ++ ppShow p | ||
1468 | where | ||
1469 | getApp acc e = e >>=. \e -> case e of | ||
1470 | EApp a b -> getApp (b: acc) a | ||
1471 | EVar n | isConstr n -> return $ Just (n, acc) | ||
1472 | _ -> return Nothing | ||
1473 | |||
1474 | evalPrimFun :: Exp -> (Exp -> Exp) -> Exp -> String -> [Exp] -> Exp | ||
1475 | evalPrimFun keep red k = f where | ||
1476 | f "primIntToFloat" [EInt i] = EFloat $ fromIntegral i | ||
1477 | f "primNegateFloat" [EFloat i] = EFloat $ negate i | ||
1478 | f "PrimSin" [EFloat i] = EFloat $ sin i | ||
1479 | f "PrimCos" [EFloat i] = EFloat $ cos i | ||
1480 | f "PrimExp" [EFloat i] = EFloat $ exp i | ||
1481 | f "PrimLog" [EFloat i] = EFloat $ log i | ||
1482 | f "PrimAbs" [EFloat i] = EFloat $ abs i | ||
1483 | f "PrimAddS" [EFloat i, EFloat j] = EFloat $ i + j | ||
1484 | f "PrimSubS" [EFloat i, EFloat j] = EFloat $ i - j | ||
1485 | f "PrimSubS" [EInt i, EInt j] = EInt $ i - j | ||
1486 | f "PrimMulS" [EFloat i, EFloat j] = EFloat $ i * j | ||
1487 | f "PrimDivS" [EFloat i, EFloat j] = EFloat $ i / j | ||
1488 | f "PrimModS" [EInt i, EInt j] = EInt $ i `mod` j | ||
1489 | f "PrimSqrt" [EInt i] = EInt $ round $ sqrt $ fromInteger i | ||
1490 | f "PrimIfThenElse" [A0 "True",t,_] = red t | ||
1491 | f "PrimIfThenElse" [A0 "False",_,e] = red e | ||
1492 | f "PrimGreaterThan" [EFloat i, EFloat j] = if i > j then TVar TBool (ExpN "True") else TVar TBool (ExpN "False") | ||
1493 | f "primCompareInt" [EInt i,EInt j] = Con0 Ordering (show $ compare i j) | ||
1494 | f "primCompareNat" [ENat i,ENat j] = Con0 Ordering (show $ compare i j) | ||
1495 | f "primCompareFloat" [EFloat i,EFloat j] = Con0 Ordering (show $ compare i j) | ||
1496 | f "primCompareString" [EString i,EString j] = Con0 Ordering (show $ compare i j) | ||
1497 | f _ _ = keep | ||
1498 | |||
1499 | pattern Prim a b <- Exp (PrimFun _ (ExpN a) b 0) | ||
1500 | pattern Prim1 a b <- Prim a [b] | ||
1501 | pattern Prim2 a b c <- Prim a [c, b] | ||
1502 | pattern Prim3 a b c d <- Prim a [d, c, b] | ||
1503 | |||
1504 | -------------------------------------------------------------------------------- Pretty show instances | ||
1505 | |||
1506 | -- TODO: eliminate | ||
1507 | showN :: N -> String | ||
1508 | showN (N _ qs s _) = show $ hcat (punctuate (pShow '.') $ map text $ qs ++ [s]) | ||
1509 | |||
1510 | showVar (N q _ n (NameInfo _ i)) = pShow q <> text n <> "{" <> i <> "}" | ||
1511 | |||
1512 | instance PShow N where | ||
1513 | pShowPrec p = \case | ||
1514 | N _ qs s (NameInfo _ i) -> hcat (punctuate (pShow '.') $ map text $ qs ++ [s]) -- <> "{" <> i <> "}" | ||
1515 | |||
1516 | instance PShow NameSpace where | ||
1517 | pShowPrec p = \case | ||
1518 | TypeNS -> "'" | ||
1519 | ExpNS -> "" | ||
1520 | |||
1521 | instance Show ConName where show = ppShow | ||
1522 | instance PShow ConName where | ||
1523 | pShowPrec p = \case | ||
1524 | ConName n -> pShow n | ||
1525 | -- ConLit l -> pShow l | ||
1526 | TupleName i -> "Tuple" <> pShow i | ||
1527 | |||
1528 | --instance PShow IdN where pShowPrec p (IdN n) = pShowPrec p n | ||
1529 | |||
1530 | instance PShow Lit where | ||
1531 | pShowPrec p = \case | ||
1532 | LInt i -> pShow i | ||
1533 | LChar i -> text $ show i | ||
1534 | LString i -> text $ show i | ||
1535 | LFloat i -> pShow i | ||
1536 | LNat i -> pShow i | ||
1537 | |||
1538 | -- Exp k i -> pInfix (-2) "::" p i k | ||
1539 | instance (PShow v, PShow p, PShow b) => PShow (Exp_ v p b) where | ||
1540 | pShowPrec p = \case | ||
1541 | EPrec_ e es -> pApps p e $ concatMap (\(a, b) -> [a, b]) es | ||
1542 | ELit_ l -> pShowPrec p l | ||
1543 | EVar_ k v -> pShowPrec p v | ||
1544 | EApp_ k a b -> pApp p a b | ||
1545 | ETyApp_ k a b -> pTyApp p a b | ||
1546 | ETuple_ a -> tupled $ map pShow a | ||
1547 | ELam_ Nothing p b -> pParens True ("\\" <> pShow p </> "->" <+> pShow b) | ||
1548 | ELam_ _ p b -> pParens True ("\\" <> braces (pShow p) </> "->" <+> pShow b) | ||
1549 | ETypeSig_ b t -> pShow b </> "::" <+> pShow t | ||
1550 | ELet_ a b c -> "let" <+> pShow a </> "=" <+> pShow b </> "in" <+> pShow c | ||
1551 | ENamedRecord_ n xs -> pShow n <+> showRecord xs | ||
1552 | ERecord_ xs -> showRecord xs | ||
1553 | EFieldProj_ k n -> "." <> pShow n | ||
1554 | EAlts_ b -> braces (vcat $ punctuate (pShow ';') $ map pShow b) | ||
1555 | Case_ t x xs -> "case" <+> pShow x <+> "of" </> vcat [pShow p <+> "->" <+> pShow e | (p, e) <- xs] | ||
1556 | ENext_ info k -> "SKIP" <+> info | ||
1557 | PrimFun k a b c -> "primfun" <+> pShow a <+> pShow b <+> pShow c | ||
1558 | |||
1559 | Star_ -> "*" | ||
1560 | TCon_ k n -> pShow n | ||
1561 | Forall_ Visible Nothing a b -> pInfixr' (-1) "->" p a b | ||
1562 | Forall_ Irrelevant Nothing a b -> pInfixr' (-1) "==>" p a b | ||
1563 | Forall_ Hidden Nothing a b -> pInfixr' (-1) "=>" p a b | ||
1564 | Forall_ Visible (Just n) a b -> "forall" <+> pParens True (pShow n </> "::" <+> pShow a) <> "." <+> pShow b | ||
1565 | Forall_ Irrelevant (Just n) a b -> "forall" <+> "." <> braces (pShow n </> "::" <+> pShow a) <> "." <+> pShow b | ||
1566 | Forall_ Hidden (Just n) a b -> "forall" <+> braces (pShow n </> "::" <+> pShow a) <> "." <+> pShow b | ||
1567 | TTuple_ a -> tupled $ map pShow a | ||
1568 | TRecord_ m -> "Record" <+> showRecord (Map.toList m) | ||
1569 | CEq_ a b -> pShow a <+> "~" <+> pShow b | ||
1570 | CUnify_ a b -> pShow a <+> "~" <+> pShow b | ||
1571 | Split_ a b c -> pShow a <+> "<-" <+> "(" <> pShow b <> "," <+> pShow c <> ")" | ||
1572 | WRefl_ k -> "refl" <+> pShow k | ||
1573 | TWildcard_ -> "twildcard" | ||
1574 | FunAlts_ i as -> "alts" <+> pShow i </> vcat [hsep (map (hcat . intersperse "@" . map pShow) ps) <+> "->" <+> pShow t | (ps, t) <- as] | ||
1575 | --- Int{-number of parameters-} [([ParPat b], GuardTree b)] | ||
1576 | |||
1577 | getConstraints = \case | ||
1578 | Exp (Forall_ (hidden -> True) n c t) -> ((n, c):) *** id $ getConstraints t | ||
1579 | t -> ([], t) | ||
1580 | |||
1581 | showConstraints cs x | ||
1582 | = (case cs of [(Nothing, c)] -> pShow c; _ -> tupled (map pShow' cs)) | ||
1583 | </> "=>" <+> pShowPrec (-2) x | ||
1584 | where | ||
1585 | pShow' (Nothing, x) = pShow x | ||
1586 | pShow' (Just n, x) = pShow n <+> "::" <+> pShow x | ||
1587 | |||
1588 | instance PShow e => PShow (Pat' e) where | ||
1589 | pShowPrec p = \case | ||
1590 | PatVar v -> pShow v | ||
1591 | PatLit l -> pShow l | ||
1592 | PatCon n ps -> hsep $ pShow n: map pShow ps | ||
1593 | PatPrec p ps -> hsep $ map pShow $ p: concatMap (\(x,y) -> [x,y]) ps | ||
1594 | -- | ViewPat e (ParPat e) | ||
1595 | |||
1596 | instance PShow e => PShow (GuardTree e) where | ||
1597 | pShowPrec p = \case | ||
1598 | GuardCon e c ps t -> pShow (PatCon c ps) <+> "<-" <+> pShow e <+> "->" <+> pShow t | ||
1599 | GuardPat e p t -> pShow p <+> "<-" <+> pShow e <+> "->" <+> pShow t | ||
1600 | -- GuardWhere (Binds e) (GuardTree e) | ||
1601 | GuardAlts as -> braces $ vcat $ map pShow as | ||
1602 | GuardExp e -> pShow e | ||
1603 | |||
1604 | instance PShow Exp where | ||
1605 | pShowPrec p = \case | ||
1606 | (getConstraints -> (cs@(_:_), t)) -> showConstraints cs t | ||
1607 | t -> case getLams t of | ||
1608 | ([], Exp e) -> pShowPrec p e | ||
1609 | (ps, Exp e) -> pParens (p > 0) $ "\\" <> hsep (map (pShowPrec 10) ps) </> "->" <+> pShow e | ||
1610 | where | ||
1611 | getLams (ELam p e) = (p:) *** id $ getLams e | ||
1612 | getLams e = ([], e) | ||
1613 | |||
1614 | instance (PShow c, PShow v, PShow b) => PShow (Pat_ t c v b) where | ||
1615 | pShowPrec p = \case | ||
1616 | PLit_ l -> pShow l | ||
1617 | PVar_ t v -> pShow v | ||
1618 | PCon_ t s xs -> pApps p s xs | ||
1619 | PTuple_ a -> tupled $ map pShow a | ||
1620 | PRecord_ xs -> "Record" <+> showRecord xs | ||
1621 | PAt_ v p -> pShow v <> "@" <> pShow p | ||
1622 | Wildcard_ t -> "_" | ||
1623 | PPrec_ e es -> pApps p e $ concatMap (\(a, b) -> [a, b]) es | ||
1624 | |||
1625 | instance PShow Pat where | ||
1626 | pShowPrec p (Pat e) = pShowPrec p e | ||
1627 | |||
1628 | instance (PShow n, PShow a) => PShow (TypeFun n a) where | ||
1629 | pShowPrec p (TypeFun s xs) = pApps p s xs | ||
1630 | |||
1631 | |||
1632 | instance PShow TEnv where | ||
1633 | pShowPrec p (TEnv e) = showRecord $ Map.toList e | ||
1634 | |||
1635 | instance PShow Item where | ||
1636 | pShowPrec p = eitherItem (\r -> (("Subst" <> if r then "!" else "") <+>) . pShow) (\rigid -> (("Sig" <> if rigid then "!" else "") <+>) . pShow) | ||
1637 | |||
1638 | instance PShow Range where | ||
1639 | pShowPrec p = \case | ||
1640 | Range a b -> text (show a) <+> "--" <+> text (show b) | ||
1641 | NoRange -> "" | ||
1642 | |||
1643 | instance PShow Definition where | ||
1644 | pShowPrec p = \case | ||
1645 | DValueDef False (ValueDef False x _) -> "ValueDef" <+> pShow x | ||
1646 | DValueDef False (ValueDef rec x _) -> "ValueDef rec" <+> pShow x | ||
1647 | DValueDef True (ValueDef False x _) -> "ValueDef [instance]" <+> pShow x | ||
1648 | DAxiom (TypeSig x _) -> "axiom" <+> pShow x | ||
1649 | DDataDef n _ _ -> "data" <+> pShow n | ||
1650 | GADT n _ _ -> "gadt" <+> pShow n | ||
1651 | ClassDef _ n _ _ -> "class" <+> pShow n | ||
1652 | InstanceDef _ n _ _ -> "instance" <+> pShow n | ||
1653 | TypeFamilyDef n _ _ -> "type family" <+> pShow n | ||
1654 | -- used only during parsing | ||
1655 | PreValueDef (_, n) _ _ -> "pre valuedef" <+> pShow n | ||
1656 | DTypeSig (TypeSig n _) -> "typesig" <+> pShow n | ||
1657 | ForeignDef n _ -> "foreign" <+> pShow n | ||
1658 | PrecDef n p -> "precdef" <+> pShow n | ||
1659 | |||
1660 | instance PShow FixityDir where | ||
1661 | pShowPrec p = \case | ||
1662 | FDLeft -> "infixl" | ||
1663 | FDRight -> "infixr" | ||
1664 | |||
1665 | -------------------------------------------------------------------------------- WriterT' | ||
1666 | |||
1667 | class Monoid' e where | ||
1668 | type MonoidConstraint e :: * -> * | ||
1669 | mempty' :: e | ||
1670 | mappend' :: e -> e -> MonoidConstraint e e | ||
1671 | |||
1672 | newtype WriterT' e m a | ||
1673 | = WriterT' {runWriterT' :: m (e, a)} | ||
1674 | deriving (Functor,Foldable,Traversable) | ||
1675 | |||
1676 | instance (Monoid' e) => MonadTrans (WriterT' e) where | ||
1677 | lift m = WriterT' $ (,) mempty' <$> m | ||
1678 | |||
1679 | instance forall m e . (Monoid' e, MonoidConstraint e ~ m, Monad m) => Applicative (WriterT' e m) where | ||
1680 | pure a = WriterT' $ pure (mempty' :: e, a) | ||
1681 | a <*> b = join $ (<$> b) <$> a | ||
1682 | |||
1683 | instance (Monoid' e, MonoidConstraint e ~ m, Monad m) => Monad (WriterT' e m) where | ||
1684 | WriterT' m >>= f = WriterT' $ do | ||
1685 | (e1, a) <- m | ||
1686 | (e2, b) <- runWriterT' $ f a | ||
1687 | e <- mappend' e1 e2 | ||
1688 | return (e, b) | ||
1689 | |||
1690 | instance (Monoid' e, MonoidConstraint e ~ m, MonadReader r m) => MonadReader r (WriterT' e m) where | ||
1691 | ask = lift ask | ||
1692 | local f (WriterT' m) = WriterT' $ local f m | ||
1693 | |||
1694 | instance (Monoid' e, MonoidConstraint e ~ m, MonadWriter w m) => MonadWriter w (WriterT' e m) where | ||
1695 | tell = lift . tell | ||
1696 | listen = error "WriterT' listen" | ||
1697 | pass = error "WriterT' pass" | ||
1698 | |||
1699 | instance (Monoid' e, MonoidConstraint e ~ m, MonadState s m) => MonadState s (WriterT' e m) where | ||
1700 | state f = lift $ state f | ||
1701 | |||
1702 | instance (Monoid' e, MonoidConstraint e ~ m, MonadError err m) => MonadError err (WriterT' e m) where | ||
1703 | catchError (WriterT' m) f = WriterT' $ catchError m $ runWriterT' <$> f | ||
1704 | throwError e = lift $ throwError e | ||
1705 | |||
1706 | mapWriterT' f (WriterT' m) = WriterT' $ f m | ||
1707 | |||
diff --git a/Typecheck.hs b/Typecheck.hs deleted file mode 100644 index c8ecbc67..00000000 --- a/Typecheck.hs +++ /dev/null | |||
@@ -1,1052 +0,0 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE PatternSynonyms #-} | ||
4 | {-# LANGUAGE ViewPatterns #-} | ||
5 | {-# LANGUAGE TypeSynonymInstances #-} | ||
6 | {-# LANGUAGE FlexibleInstances #-} | ||
7 | {-# LANGUAGE NoMonomorphismRestriction #-} | ||
8 | {-# LANGUAGE TypeFamilies #-} | ||
9 | {-# LANGUAGE RecordWildCards #-} | ||
10 | {-# LANGUAGE FlexibleContexts #-} -- for ghc-7.10.1 | ||
11 | {-# LANGUAGE ScopedTypeVariables #-} | ||
12 | {-# LANGUAGE MultiParamTypeClasses #-} | ||
13 | {-# LANGUAGE DeriveFunctor #-} | ||
14 | {-# LANGUAGE DeriveFoldable #-} | ||
15 | {-# LANGUAGE DeriveTraversable #-} | ||
16 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} | ||
17 | {-# LANGUAGE StandaloneDeriving #-} | ||
18 | {-# LANGUAGE UndecidableInstances #-} | ||
19 | {-# LANGUAGE DataKinds #-} | ||
20 | {-# LANGUAGE ConstraintKinds #-} | ||
21 | {-# LANGUAGE GADTs #-} | ||
22 | {-# LANGUAGE RankNTypes #-} | ||
23 | module Typecheck where | ||
24 | |||
25 | import Data.Function | ||
26 | import Data.List | ||
27 | import Data.Maybe | ||
28 | import Data.Either | ||
29 | import Data.Monoid | ||
30 | import Data.Foldable (Foldable, foldMap, toList, foldrM) | ||
31 | import qualified Data.Traversable as T | ||
32 | import Data.Map (Map) | ||
33 | import qualified Data.Map as Map | ||
34 | import Data.Set (Set) | ||
35 | import qualified Data.Set as Set | ||
36 | import Control.Applicative | ||
37 | import Control.Monad.Except | ||
38 | import Control.Monad.State | ||
39 | import Control.Monad.Reader | ||
40 | import Control.Monad.Writer | ||
41 | import Control.Monad.Identity | ||
42 | import Control.Arrow hiding ((<+>)) | ||
43 | import Debug.Trace | ||
44 | import GHC.Exts (Constraint) | ||
45 | |||
46 | import Text.Parsec.Pos | ||
47 | |||
48 | import Pretty | ||
49 | import Type | ||
50 | import Parser | ||
51 | |||
52 | -------------------------------------------------------------------------------- | ||
53 | |||
54 | trace'' _ x = x | ||
55 | |||
56 | pairsWith f xs = zipWith f xs $ drop 1 xs | ||
57 | |||
58 | unifyMaps_ :: (Ord a) => (a -> Doc) -> [Map a b] -> [WithExplanation [b]] | ||
59 | unifyMaps_ f ms = {-case filter (not . Map.null) ms of | ||
60 | [] -> [] | ||
61 | [m] -> [] | ||
62 | ms -> -} map (f *** id) . filter (not . null . drop 1 . snd) . Map.toList . Map.unionsWith (++) . map ((:[]) <$>) $ ms | ||
63 | |||
64 | unifyMaps :: (Ord a, PShow a) => [Map a b] -> [WithExplanation [b]] | ||
65 | unifyMaps = unifyMaps_ pShow | ||
66 | |||
67 | groupByFst :: (Ord a, PShow a) => [(a, b)] -> [WithExplanation [b]] | ||
68 | groupByFst = unifyMaps . map (uncurry Map.singleton) | ||
69 | |||
70 | matches TVar{} _ = True | ||
71 | matches x ts = x `elem'` ts | ||
72 | |||
73 | elem' a b = b a | ||
74 | |||
75 | isRec TRecord{} = True | ||
76 | isRec t = isVar t | ||
77 | |||
78 | isVar TVar{} = True | ||
79 | isVar _ = False | ||
80 | |||
81 | nat234 (ENat i) = i `elem` [2..4] | ||
82 | nat234 _ = False | ||
83 | |||
84 | floatIntWordBool = \case | ||
85 | TFloat -> True | ||
86 | TInt -> True | ||
87 | TWord -> True | ||
88 | TBool -> True | ||
89 | _ -> False | ||
90 | |||
91 | data InjType | ||
92 | = ITMat | ITVec | ITVecScalar | ||
93 | deriving (Show, Eq, Ord) | ||
94 | |||
95 | instance PShow InjType where | ||
96 | pShowPrec p = text . show | ||
97 | |||
98 | injType :: TypeFunT -> Maybe (InjType, [Exp]) | ||
99 | injType = \case | ||
100 | TFMat a b -> Just (ITMat, [a, b]) | ||
101 | TFVec a b -> Just (ITVec, [a, b]) | ||
102 | TFVecScalar a b -> Just (ITVecScalar, [a, b]) | ||
103 | _ -> Nothing | ||
104 | |||
105 | |||
106 | {- TODO | ||
107 | type family NoStencilRepr a :: * | ||
108 | type instance NoStencilRepr ZZ = ZZ | ||
109 | type instance NoStencilRepr (Stencil a :+: b) = NoStencilRepr b | ||
110 | type instance NoStencilRepr (Color a :+: b) = Color a :+: NoStencilRepr b | ||
111 | type instance NoStencilRepr (Depth a :+: b) = Depth a :+: NoStencilRepr b | ||
112 | -} | ||
113 | |||
114 | {- currently not used | ||
115 | [injective] type family PrimitiveVertices (primitive :: PrimitiveType) a | ||
116 | type instance PrimitiveVertices Point a = a | ||
117 | type instance PrimitiveVertices Line a = (a,a) | ||
118 | type instance PrimitiveVertices LineAdjacency a = (a,a,a,a) | ||
119 | type instance PrimitiveVertices Triangle a = (a,a,a) | ||
120 | type instance PrimitiveVertices TriangleAdjacency a = (a,a,a,a,a,a) | ||
121 | -} | ||
122 | {- currently not used | ||
123 | - texturing - | ||
124 | [semiinjective] type family TexDataRepr arity (t :: TextureSemantics *) | ||
125 | type instance TexDataRepr Red (v a) = a | ||
126 | type instance TexDataRepr RG (v a) = V2 a | ||
127 | type instance TexDataRepr RGB (v a) = V3 a | ||
128 | type instance TexDataRepr RGBA (v a) = V4 a | ||
129 | |||
130 | [injective if (= SigleTex)] type family TexArrRepr (a :: Nat) :: TextureArray | ||
131 | --type instance TexArrRepr 1 = SingleTex | ||
132 | --type instance TexArrRepr ((2 <= t) => t) = ArrayTex | ||
133 | -- FIXME: implement properly | ||
134 | type instance TexArrRepr 1 = SingleTex | ||
135 | type instance TexArrRepr 2 = ArrayTex | ||
136 | type instance TexArrRepr 3 = ArrayTex | ||
137 | type instance TexArrRepr 4 = ArrayTex | ||
138 | type instance TexArrRepr 5 = ArrayTex | ||
139 | type instance TexArrRepr 6 = ArrayTex | ||
140 | type instance TexArrRepr 7 = ArrayTex | ||
141 | type instance TexArrRepr 8 = ArrayTex | ||
142 | type instance TexArrRepr 9 = ArrayTex | ||
143 | |||
144 | [semiinjective] type family TexSizeRepr (a :: TextureShape) | ||
145 | type instance TexSizeRepr (Tex1D) = Word32 | ||
146 | type instance TexSizeRepr (Tex2D) = V2U | ||
147 | type instance TexSizeRepr (TexRect) = V2U | ||
148 | type instance TexSizeRepr (Tex3D) = V3U | ||
149 | |||
150 | [injective in 4th param, semiinjective in 3rd param] type family TexelRepr sampler | ||
151 | type instance TexelRepr (Sampler dim arr (v t) Red) = t | ||
152 | type instance TexelRepr (Sampler dim arr (v t) RG) = V2 t | ||
153 | type instance TexelRepr (Sampler dim arr (v t) RGB) = V3 t | ||
154 | type instance TexelRepr (Sampler dim arr (v t) RGBA) = V4 t | ||
155 | -} | ||
156 | |||
157 | |||
158 | -------------------------------------------------------------------------------- constraints reduction | ||
159 | |||
160 | type ConstraintSolvRes = (TEnv, [WithExplanation [Exp]]) | ||
161 | |||
162 | reduceConstraint :: IdN -> Exp -> TCM ConstraintSolvRes | ||
163 | reduceConstraint a b = reduceConstraint_ a b b | ||
164 | |||
165 | reduceConstraint_ :: forall m . (m ~ TCM) => IdN -> Exp -> Exp -> m ConstraintSolvRes | ||
166 | reduceConstraint_ cvar orig x = do | ||
167 | builtinInstances <- asks instanceDefs | ||
168 | pe <- asks getPolyEnv | ||
169 | case x of | ||
170 | -- hack for swizzling; TODO: define Vec as a structural record instead | ||
171 | Split (TVec n a) c@TVar{} (TSingRecord s a') -> case n of | ||
172 | 4 | s `elem` (map ExpN ["x","y","z","w"]) -> discard' [WithExplanation "vec-split" [a, a'], WithExplanation "vec-split'" [c, TVec 3 a]] | ||
173 | 3 | s `elem` (map ExpN ["x","y","z"]) -> discard' [WithExplanation "vec-split" [a, a'], WithExplanation "vec-split'" [c, TVec 2 a]] | ||
174 | 2 | s `elem` (map ExpN ["x","y"]) -> discard' [WithExplanation "vec-split" [a, a'], WithExplanation "vec-split'" [c, TVec 1 a]] | ||
175 | _ -> fail "bad swizzling" | ||
176 | Split (TRecord a) (TRecord b) (TRecord c) -> | ||
177 | case (Map.keys $ Map.intersection b c, Map.keys $ a Map.\\ (b <> c), Map.keys $ (b <> c) Map.\\ a) of | ||
178 | ([], [], []) -> discard' $ unifyMaps [a, b, c] | ||
179 | -- ks -> failure $ "extra keys:" <+> pShow ks | ||
180 | Split (TRecord a) (TRecord b) c@TVar{} -> diff a b c | ||
181 | Split (TRecord a) c@TVar{} (TRecord b) -> diff a b c | ||
182 | Split c@TVar{} (TRecord a) (TRecord b) -> case Map.keys $ Map.intersection a b of | ||
183 | [] -> discard' [WithExplanation "???" [c, TRecord $ a <> b]] | ||
184 | -- ks -> failure $ "extra keys:" <+> pShow ks | ||
185 | Split a b c | ||
186 | | isRec a && isRec b && isRec c -> nothing | ||
187 | -- | otherwise -> failure $ "bad split:" <+> pShow x | ||
188 | |||
189 | ctr@(getApp -> Just (c, ts)) | ||
190 | | all isVar ts -> nothing | ||
191 | | otherwise -> case c of | ||
192 | |||
193 | IsTypeLevelNatural -> case ts of | ||
194 | [TNat{}] -> discard' [] | ||
195 | _ -> noInstance | ||
196 | |||
197 | IsValidOutput -> discard' [] -- TODO | ||
198 | |||
199 | IsValidFrameBuffer -> case ts of | ||
200 | [TTuple ts] | ||
201 | | any isVar ts -> nothing | ||
202 | | sum [1 | Depth{} <- ts] <= 1 && sum [1 | Stencil{} <- ts] <= 1 -> discard' [] | ||
203 | | otherwise -> noInstance | ||
204 | [_] -> discard' [] | ||
205 | -- _ -> noInstance -- impossible? | ||
206 | |||
207 | IsAttributeTuple -> case ts of | ||
208 | [TTuple ts] | ||
209 | | any isVar ts -> nothing | ||
210 | | length [() | a <- ts, Set.member a validAttributes] == length ts -> discard' [] | ||
211 | | otherwise -> noInstance | ||
212 | [_] -> discard' [] | ||
213 | where | ||
214 | validAttributes = Set.fromList $ [ TMat 2 2 TFloat, TMat 2 3 TFloat, TMat 2 4 TFloat | ||
215 | , TMat 3 2 TFloat, TMat 3 3 TFloat, TMat 3 4 TFloat | ||
216 | , TMat 4 2 TFloat, TMat 4 3 TFloat, TMat 4 4 TFloat | ||
217 | , TFloat, TInt, TWord, TBool | ||
218 | ] ++ concat [[TVec 2 a, TVec 3 a, TVec 4 a] | a <- [TFloat, TInt, TWord, TBool]] | ||
219 | |||
220 | _ -> findInstance (const nothing) cvar ctr | ||
221 | where | ||
222 | findInstance failure cvar ctr@(getApp -> Just (c, ts)) | ||
223 | | all isVar ts = nothing | ||
224 | | otherwise = maybe nothing (findWitness failure cvar ctr) $ Map.lookup c builtinInstances | ||
225 | findInstance _ _ ctr = error $ "findInstance: " ++ ppShow ctr | ||
226 | |||
227 | findWitness failure' cvar tt m = do | ||
228 | let is :: [(Name, Exp)] | ||
229 | is = [(n, tyOfItem e) | n@(flip Map.lookup pe -> Just e) <- Map.keys m] | ||
230 | |||
231 | res <- trace'' (ppShow is) $ forM is $ \(n, t') -> catchExc $ do | ||
232 | (se_, (fn, t_)) <- runWriterT' $ do | ||
233 | (fn, t'') <- toTCMS t' | ||
234 | trace'' ("checking " ++ ppShow (t', (fn, t''), tt)) $ | ||
235 | addUnifOneDir t'' tt | ||
236 | trace'' "ok" $ return (fn, t'') | ||
237 | css <- forM (zip fn $ subst (toSubst se_) fn) $ \case | ||
238 | (TVar _ cc, TVar ctr _) -> do | ||
239 | (cs, []) <- findInstance failure cc ctr | ||
240 | return cs | ||
241 | _ -> return mempty | ||
242 | se <- joinSE $ se_: css | ||
243 | let x = subst (toSubst se) $ buildApp (`TVar` n) t_ fn | ||
244 | trace'' ("eer: " ++ ppShow (se, cvar, x)) $ return ((n, t'), (singSubst cvar x <> se, [])) | ||
245 | case [x | Just x <- res] of | ||
246 | [x] -> return $ snd x | ||
247 | [] -> failure' $ msg' </> "possible instances:" </> pShow [x | (n, x) <- is] | ||
248 | ws -> failure $ msg' </> "overlapping instances:" </> pShow (map fst ws) | ||
249 | where | ||
250 | msg' = "no instance for" <+> pShow tt | ||
251 | noInstance = failure msg' | ||
252 | |||
253 | msg' = "no" <+> pShow c <+> "instance for" <+> pShow ts | ||
254 | noInstance = failure msg' | ||
255 | |||
256 | CUnify a b -> discard' [WithExplanation "~~~" [a, b]] | ||
257 | |||
258 | CEq res f -> case f of | ||
259 | |||
260 | TFMat (TVec n TFloat) (TVec m TFloat) -> reduced $ TMat n m TFloat | ||
261 | TFMat a b -> observe res $ \case | ||
262 | TMat n m t -> keep [WithExplanation "Mat res 1" [a, TVec n t], WithExplanation "Mat res 2" [b, TVec m t]] | ||
263 | _ -> fail "no instance" | ||
264 | |||
265 | TFVec (ENat n) ty | n `elem` [2,3,4] {- && ty `elem'` floatIntWordBool -} -> reduced $ TVec n ty | ||
266 | TFVec a b -> check (a `matches` nat234 && b `matches` floatIntWordBool {- -- FIXME -}) $ observe res $ \case | ||
267 | TVec n t -> keep [WithExplanation "Vec res 1" [a, ENat n], WithExplanation "Vec res 2" [b, t]] | ||
268 | _ -> fail "no instance tfvec" | ||
269 | |||
270 | TFVecScalar a b -> case a of | ||
271 | ENat 1 -> case b of | ||
272 | TVar{} | res `matches` floatIntWordBool -> keep [WithExplanation "VecScalar dim 1" [b, res]] | ||
273 | b -> check (b `elem'` floatIntWordBool) $ reduced b | ||
274 | TVar{} -> check (b `matches` floatIntWordBool) $ observe res $ \case | ||
275 | t | t `elem'` floatIntWordBool -> keep [WithExplanation "VecScalar res 1" [a, ENat 1], WithExplanation "VecScalar res 2" [b, t]] | ||
276 | TVec n t -> keep [WithExplanation "VecScalar res 1" [a, ENat n], WithExplanation "VecScalar res 2" [b, t]] | ||
277 | _ -> nothing --like $ TFVec a b | ||
278 | _ -> like $ TFVec a b | ||
279 | |||
280 | TFMatVecElem t -> observe t $ \case | ||
281 | TVec _ t -> reduced t | ||
282 | TMat _ _ t -> reduced t | ||
283 | _ -> fail $ "no instance matvecelem" <+> pShow t | ||
284 | |||
285 | TFMatVecScalarElem t -> observe t $ \case | ||
286 | t | t `elem'` floatIntWordBool -> reduced t | ||
287 | t -> like $ TFMatVecElem t | ||
288 | |||
289 | TFColorRepr ty -> observe ty $ \case | ||
290 | TTuple ts -> reduced . TTuple $ map Color ts | ||
291 | ty -> reduced $ Color ty | ||
292 | |||
293 | TFFTRepr' ty -> caseTuple "expected List/Interpolated/Depth/Color" ty (reduced . tTuple) $ \case | ||
294 | TInterpolated a -> reduce' a | ||
295 | Depth a -> reduce' a | ||
296 | Color a -> reduce' a | ||
297 | TList a -> reduce' a | ||
298 | _ -> fail' | ||
299 | |||
300 | TFFragOps ty -> caseTuple "expected FragmentOperation" ty (reduced . tTuple) $ \case | ||
301 | TFragmentOperation a -> reduce' a | ||
302 | _ -> fail' | ||
303 | |||
304 | TFFrameBuffer ty -> caseTuple "expected (Image Nat)" ty end $ \case | ||
305 | TImage a b -> observe' a $ \case | ||
306 | ENat n -> reduce' (n, b) | ||
307 | _ -> fail' | ||
308 | _ -> fail' | ||
309 | where | ||
310 | end (unzip -> (n: ns, tys)) | ||
311 | | all (==n) ns = reduced $ TFrameBuffer (ENat n) $ tTuple tys | ||
312 | | otherwise = fail "frambuffer number of layers differ" | ||
313 | |||
314 | TFJoinTupleType (TTuple []) x -> reduced x | ||
315 | TFJoinTupleType x (TTuple []) -> reduced x | ||
316 | TFJoinTupleType TVar{} _ -> nothing -- TODO: observe res? | ||
317 | TFJoinTupleType _ TVar{} -> nothing -- TODO: observe res? | ||
318 | TFJoinTupleType (TTuple l) (TTuple r) -> reduced $ TTuple (l ++ r) | ||
319 | TFJoinTupleType l (TTuple r) -> reduced $ TTuple (l : r) | ||
320 | TFJoinTupleType (TTuple l) r -> reduced $ TTuple (l ++ [r]) | ||
321 | TFJoinTupleType l r -> reduced $ TTuple [l,r] | ||
322 | |||
323 | _ -> error $ "Unknown type function: " ++ ppShow f | ||
324 | |||
325 | where | ||
326 | like f = reduceConstraint_ cvar x (CEq res f) | ||
327 | reduced t = discard' [WithExplanation "type family reduction" [res, t]] | ||
328 | check b m = if b then m else fail "no instance (1)" | ||
329 | fail :: Doc -> m ConstraintSolvRes | ||
330 | fail = failure . (("error during reduction of" </> pShow res <+> "~" <+> pShow f) </>) | ||
331 | |||
332 | reduce' = Just . Just | ||
333 | nothing' = Just Nothing | ||
334 | fail' = Nothing | ||
335 | observe' TVar{} _ = nothing' | ||
336 | observe' x f = f x | ||
337 | |||
338 | caseTuple :: Doc -> Exp -> ([a] -> m ConstraintSolvRes) -> (Exp -> Maybe (Maybe a)) -> m ConstraintSolvRes | ||
339 | caseTuple msg ty end f = observe ty $ \case | ||
340 | TTuple ts -> maybe (fail $ msg <+> "inside tuple") (maybe nothing end . sequence) $ mapM f' ts | ||
341 | _ -> maybe (fail msg) (maybe nothing (end . (:[]))) $ f' ty | ||
342 | where f' x = observe' x f | ||
343 | |||
344 | tTuple [x] = x | ||
345 | tTuple xs = TTuple xs | ||
346 | _ -> nothing | ||
347 | |||
348 | where | ||
349 | diff a b c = case Map.keys $ b Map.\\ a of | ||
350 | [] -> discard' $ WithExplanation "???" [c, TRecord $ a Map.\\ b]: unifyMaps [a, b] | ||
351 | -- ks -> failure $ "extra keys:" <+> pShow ks | ||
352 | discard w xs = return (singSubst cvar w, xs) | ||
353 | discard' xs = discard (WRefl orig) xs | ||
354 | keep xs = return (mempty, xs) | ||
355 | failure :: Doc -> m ConstraintSolvRes | ||
356 | failure = throwErrorTCM | ||
357 | |||
358 | nothing = return mempty | ||
359 | observe TVar{} _ = nothing | ||
360 | observe x f = f x | ||
361 | |||
362 | -------------------------------------------------------------------------------- | ||
363 | |||
364 | -- unify each types in the sublists | ||
365 | unifyTypes :: forall m . (MonadPlus m, MonadState FreshVars m, MonadError ErrorMsg m) => Bool -> [WithExplanation [Exp]] -> m TEnv | ||
366 | unifyTypes bidirectional tys = flip execStateT mempty $ forM_ tys $ sequence_ . pairsWith uni . snd | ||
367 | where | ||
368 | -- uni :: Exp -> Exp -> StateT TEnv TCM () | ||
369 | uni a b = gets (subst1{-could be subst-} . toSubst) >>= \f -> unifyTy (f $ reduceHNF a) (f $ reduceHNF b) | ||
370 | |||
371 | -- make single tvar substitution; check infinite types | ||
372 | bindVar n t = do | ||
373 | s <- get | ||
374 | let t' = subst_ (toSubst s) t | ||
375 | if n `Set.member` freeVars t' | ||
376 | then throwErrorTCM $ "Infinite type, type variable" <+> pShow n <+> "occurs in" <+> pShow t' | ||
377 | else put $ singSubst n t' <> s | ||
378 | |||
379 | bindVars a@(TVar tu u) b@(TVar tv v) = case (compare u v, bidirectional) of | ||
380 | (EQ, _) -> return () | ||
381 | (GT, True) -> bindVar v (TVar tu u) | ||
382 | _ -> bindVar u (TVar tv v) | ||
383 | |||
384 | -- unifyTy :: Exp -> Exp -> StateT Subst m () | ||
385 | unifyTy (Exp t) (Exp t') = unifyTy' t t' | ||
386 | where | ||
387 | -- unifyTy' (Forall_ Hidden n a1 b1) x = maybe (lift $ newName "?") return n >>= \n -> put (singSubstTy_ n a1) >> uni b1 (Exp x) | ||
388 | -- unifyTy' x (Forall_ Hidden n a1 b1) = maybe (lift $ newName "?") return n >>= \n -> put (singSubstTy_ n a1) >> uni b1 (Exp x) | ||
389 | unifyTy' (Forall_ Visible (Just a) k t) (Forall_ Visible (Just a') k' t') = do | ||
390 | uni k k' | ||
391 | a'' <- lift $ newName "unifyTy" | ||
392 | modify $ TEnv . Map.insert a'' (ISig False k) . getTEnv | ||
393 | -- TODO! protect a in t | ||
394 | -- if ppShow a' == "t1755" then throwErrorTCM "!!!" else | ||
395 | uni (subst (Subst $ Map.singleton a $ TVar k a'') t) ({-trace (ppShow (a', a, k)) $ -} subst (Subst $ Map.singleton a' $ TVar k a'') t') | ||
396 | --bindVars (TVar k a) (TVar k' a') >> uni t t' | ||
397 | unifyTy' (Forall_ Visible Nothing a1 b1) (Forall_ Visible Nothing a2 b2) = uni a1 a2 >> uni b1 b2 | ||
398 | unifyTy' (EVar_ k u) (EVar_ k' v) = uni k k' >> bindVars (Exp t) (Exp t') | ||
399 | unifyTy' (EVar_ k u) _ = bindVar u (Exp t') | ||
400 | unifyTy' _ (EVar_ k v) | bidirectional = bindVar v (Exp t) | ||
401 | unifyTy' (ELit_ l) (ELit_ l') | l == l' = return () | ||
402 | unifyTy' (TCon_ k u) (TCon_ k' v) | u == v = uni k k' >> return () | ||
403 | unifyTy' (TTuple_ t1) (TTuple_ t2) = sequence_ $ zipWith uni t1 t2 | ||
404 | unifyTy' (EApp_ k a1 b1) (EApp_ k' a2 b2) = uni k k' >> uni a1 a2 >> uni b1 b2 | ||
405 | unifyTy' Star_ Star_ = return () | ||
406 | unifyTy' (TRecord_ xs) (TRecord_ xs') | Map.keys xs == Map.keys xs' = sequence_ $ zipWith uni (Map.elems xs) (Map.elems xs') | ||
407 | unifyTy' (CUnify_ a b) (CUnify_ a' b') = uni a a' >> uni b b' -- ??? | ||
408 | unifyTy' (CEq_ a (TypeFun n b)) (CEq_ a' (TypeFun n' b')) | n == n' = uni a a' >> sequence_ (zipWith uni b b') -- ??? | ||
409 | unifyTy' (Split_ a b c) (Split_ a' b' c') = uni a a' >> uni b b' >> uni c c' -- ??? | ||
410 | unifyTy' (WRefl_ a) (WRefl_ b) = uni a b | ||
411 | unifyTy' _ _ | ||
412 | | otherwise = throwError $ UnificationError (Exp t) (Exp t') $ filter (not . null . drop 1 . snd) tys | ||
413 | |||
414 | -- TODO: revise applications | ||
415 | appSES :: (Substitute Subst x, PShow x, Monad m) => TypingT m x -> TypingT m x | ||
416 | appSES = mapWriterT' $ fmap $ \(se, x) -> | ||
417 | let | ||
418 | su = toSubst se | ||
419 | in (subst su $ TEnv $ Map.filter (eitherItem (\r _ -> not r) (\_ _ -> True)) $ getTEnv se, subst su x) | ||
420 | |||
421 | removeMonoVars = mapWriterT' $ fmap $ \(en@(TEnv se), (s, x)) -> let | ||
422 | su = toSubst en | ||
423 | in (TEnv $ foldr Map.delete se $ {-map (subst' su) $ -} Set.toList s, subst su x) | ||
424 | {- | ||
425 | where | ||
426 | subst' (Subst m) n | Just (EVar i) <- Map.lookup n m = i | ||
427 | | otherwise = n | ||
428 | -} | ||
429 | runWriterT'' = runWriterT' . appSES | ||
430 | |||
431 | closeSubst (TEnv m) = s where s = TEnv $ subst (toSubst s) <$> m | ||
432 | |||
433 | joinSubsts :: [TEnv] -> TCM TEnv | ||
434 | joinSubsts (map getTEnv -> ss) = case filter (not . Map.null) ss of | ||
435 | [] -> return mempty | ||
436 | [x] -> return $ TEnv x | ||
437 | ss -> do | ||
438 | s <- addCtx "joinSubsts" $ unifyTypes True $ concatMap ff $ unifyMaps ss | ||
439 | if nullTEnv s | ||
440 | then return $ closeSubst $ TEnv $ Map.unionsWith mergeSubsts ss | ||
441 | else joinSubsts [s, TEnv $ Map.unionsWith mergeSubsts ss] | ||
442 | where | ||
443 | ff (expl, ss) = case ( WithExplanation (expl <+> "subst") [s | ISubst _ s <- ss] | ||
444 | , WithExplanation (expl <+> "typesig") [s | ISig rigid s <- ss]) of | ||
445 | (WithExplanation _ [], ss) -> [ss] | ||
446 | (ss, WithExplanation _ []) -> [ss] | ||
447 | (subs@(WithExplanation i (s:_)), sigs@(WithExplanation i' (s':_))) -> [subs, sigs, WithExplanation ("subskind" <+> i <+> i') [tyOf s, s']] | ||
448 | |||
449 | joinSE :: [TEnv] -> TCM TEnv | ||
450 | joinSE ts = case ts of | ||
451 | [a, b] | ||
452 | | Map.null $ getTEnv a -> return b -- optimization | ||
453 | | Map.null $ getTEnv b -> return a -- optimization | ||
454 | ab -> swapRule <$> (joinSubsts ab >>= untilNoUnif) | ||
455 | |||
456 | swapRule (TEnv te) = TEnv $ foldr f te vs | ||
457 | where | ||
458 | vs = [(v1, v2, t) | (v1, ISubst False (TVar t v2)) <- Map.toList te, v1 < v2] | ||
459 | f (v1, v2, t) m = case Map.lookup v2 m of | ||
460 | Just (ISubst True (TVar _ v)) | ||
461 | | v == v1 -> Map.delete v1 m | ||
462 | | otherwise -> m | ||
463 | Just (ISig False _) -> Map.insert v2 (ISubst True $ TVar t v1) $ Map.delete v1 m | ||
464 | Nothing -> m | ||
465 | |||
466 | writerT' x = WriterT' $ do | ||
467 | (me, t) <- x | ||
468 | me <- untilNoUnif me | ||
469 | return (me, t) | ||
470 | |||
471 | addUnif, addUnifOneDir :: Exp -> Exp -> TCMS () | ||
472 | addUnif a b = addUnifs True [[a, b]] | ||
473 | addUnifOneDir a b = addUnifs True [[a, b]] | ||
474 | |||
475 | addUnifs :: Bool -> [[Exp]] -> TCMS () | ||
476 | addUnifs twodir ts = writerT' $ do | ||
477 | m <- addCtx "addUnifs" (unifyTypes twodir $ map (WithExplanation "~~~") ts) | ||
478 | return (m, ()) | ||
479 | |||
480 | untilNoUnif :: TEnv -> TCM TEnv | ||
481 | untilNoUnif es = do | ||
482 | let cs = [(n, c) | (n, ISig False c) <- Map.toList $ getTEnv es] | ||
483 | (unzip -> (ss, concat -> eqs)) <- mapM (uncurry reduceConstraint) cs | ||
484 | s0 <- addCtx "untilNoUnif" $ unifyTypes True | ||
485 | -- unify left hand sides where the right hand side is equal: (t1 ~ F a, t2 ~ F a) --> t1 ~ t2 | ||
486 | $ groupByFst [(f, ty) | CEq ty f <- map snd cs] | ||
487 | -- injectivity test: (t ~ Vec a1 b1, t ~ Vec a2 b2) --> a1 ~ a2, b1 ~ b2 | ||
488 | ++ concatMap (\(s, l) -> map ((,) s) $ transpose l) | ||
489 | (groupByFst | ||
490 | [((ty, it), is) | CEq ty (injType -> Just (it, is)) <- map snd cs]) | ||
491 | ++ eqs | ||
492 | |||
493 | -- (a :: Num X, b :: Num X) ----> a := TVar (Num X) b | ||
494 | let ff ((n, _):xs) = [(n, TVar c x) | (x, c) <- xs] | ||
495 | let s1 = Subst $ Map.fromList $ concatMap (\(WithExplanation _ xs) -> ff xs) $ groupByFst [(x, (n, x)) | (n, x) <- cs, isConstraint x] | ||
496 | -- trace ("---" ++ ppShow s1) $ | ||
497 | if nullTEnv s0 && nullSubst s1 && all nullTEnv ss then return es else do | ||
498 | joinSubsts (s0: toTEnv s1: es: ss) >>= untilNoUnif | ||
499 | |||
500 | isConstraint (getApp -> Just _) = True | ||
501 | isConstraint _ = False | ||
502 | |||
503 | instance Monoid' TEnv where | ||
504 | type MonoidConstraint TEnv = TCM | ||
505 | mempty' = mempty | ||
506 | mappend' a b = joinSE [a, b] | ||
507 | |||
508 | -------------------------------------------------------------------------------- | ||
509 | |||
510 | singSubstTy a b = addConstraints $ singSubstTy_ a b | ||
511 | singSubstTy' a b = WriterT' $ pure (singSubstTy_ a b, ()) | ||
512 | |||
513 | newStarVar' :: Doc -> Name -> TCMS Exp | ||
514 | newStarVar' i n = do | ||
515 | t <- newStarVar $ i <+> pShow n | ||
516 | singSubstTy' n t | ||
517 | return t | ||
518 | |||
519 | newStarVar :: Doc -> TCMS Exp | ||
520 | newStarVar i = newVar i Star | ||
521 | |||
522 | newVar :: Doc -> Exp -> TCMS Exp | ||
523 | newVar i k = do | ||
524 | n <- newName i | ||
525 | singSubstTy' n k | ||
526 | return $ TVar k n | ||
527 | |||
528 | addConstraints m = writerT' $ pure (m, ()) | ||
529 | addConstraint c = newName "constraint" >>= \n -> singSubstTy n c | ||
530 | |||
531 | checkStarKind Star = return () | ||
532 | checkStarKind t = addUnif Star $ tyOf t | ||
533 | |||
534 | ---------------------------- | ||
535 | |||
536 | instantiateTyping :: Doc -> TCMS Exp -> TCM Exp | ||
537 | instantiateTyping i ty = do | ||
538 | (se, ty) <- runWriterT'' ty | ||
539 | x <- instantiateTyping_' False i se ty | ||
540 | return $ snd x | ||
541 | |||
542 | |||
543 | lookEnv :: Name -> TCMS ([Exp], Exp) -> TCMS ([Exp], Exp) | ||
544 | lookEnv n m = asks (Map.lookup n . getPolyEnv) >>= maybe m (toTCMS . tyOfItem) | ||
545 | |||
546 | lookEnv' n m = asks (Map.lookup n . typeFamilies) >>= maybe m toTCMS | ||
547 | |||
548 | -------------------------------------------------------------------------------- | ||
549 | |||
550 | calcPrec | ||
551 | :: (MonadError ErrorMsg m, PShow e) | ||
552 | => (e -> e -> e -> e) | ||
553 | -> (e -> Name) | ||
554 | -> PrecMap | ||
555 | -> e | ||
556 | -> [(e, e)] | ||
557 | -> m e | ||
558 | calcPrec app getname ps e es = do | ||
559 | compileOps [((Nothing, -1), undefined, e)] es | ||
560 | where | ||
561 | compileOps [(_, _, e)] [] = return e | ||
562 | compileOps acc [] = compileOps (shrink acc) [] | ||
563 | compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of | ||
564 | Right GT -> compileOps ((pr, op, e'): acc) es | ||
565 | Right LT -> compileOps (shrink acc) es_ | ||
566 | Left err -> throwErrorTCM err | ||
567 | where | ||
568 | pr = fromMaybe --(error $ "no prec for " ++ ppShow n) | ||
569 | (Just FDLeft, 9) | ||
570 | $ Map.lookup (getname op) ps | ||
571 | |||
572 | shrink ((_, op, e): (pr, op', e'): es) = (pr, op', app op e' e): es | ||
573 | |||
574 | compareFixity ((dir, i), op) ((dir', i'), op') | ||
575 | | i > i' = Right GT | ||
576 | | i < i' = Right LT | ||
577 | | otherwise = case (dir, dir') of | ||
578 | (Just FDLeft, Just FDLeft) -> Right LT | ||
579 | (Just FDRight, Just FDRight) -> Right GT | ||
580 | _ -> Left $ "fixity error:" <+> pShow (op, op') | ||
581 | |||
582 | -------------------------------------------------------------------------------- | ||
583 | |||
584 | appTy (TArr ta v) ta' = addUnif ta ta' >> return v -- optimalization | ||
585 | appTy tf ta = newStarVar ("tapp" <+> pShow tf <+> "|" <+> pShow ta) >>= \v -> addUnif tf (ta ~> v) >> return v | ||
586 | |||
587 | forallApp (Forall x k y) t = do | ||
588 | addUnif (tyOf t) k | ||
589 | return $ subst (Subst $ Map.singleton x t) y | ||
590 | forallApp tt t = do -- ??? | ||
591 | throwErrorTCM $ "can't unify" <+> pShow tt <+> "with" <+> "forall" | ||
592 | {- | ||
593 | x' <- newName "forallApp" | ||
594 | y <- newStarVar "etyapp" | ||
595 | addUnif tt (Forall x' (tyOf t) y) | ||
596 | return y -- $ subst (Subst $ Map.singleton x $ TVar k x') y | ||
597 | -} | ||
598 | |||
599 | |||
600 | getRes 0 x = Just ([], x) | ||
601 | getRes i (TArr a b) = ((a:) *** id) <$> getRes (i-1) b | ||
602 | getRes _ _ = Nothing | ||
603 | |||
604 | starV (TVar t n) = monoInstType n t | ||
605 | |||
606 | inferPatTyping :: Bool -> PatR -> TCMS (Pat, InstEnv) | ||
607 | inferPatTyping polymorph p_@(PatR pt p) = addRange pt $ addCtx ("type inference of pattern" <+> pShow p_) $ case p of | ||
608 | |||
609 | PPrec_ e es -> do | ||
610 | ps <- asks precedences | ||
611 | inferPatTyping polymorph =<< calcPrec (\a b c -> appP' a [b, c]) (\(PCon' _ n []) -> n) ps e es | ||
612 | |||
613 | PVar_ _{-TODO-} n -> do | ||
614 | t <- newStarVar $ "pvar" <> pShow pt | ||
615 | return (PVar t n, monoInstType n t) | ||
616 | _ -> do | ||
617 | p <- traverse (inferPatTyping polymorph) p | ||
618 | (res, tr) <- case p of | ||
619 | PCon_ _{-TODO-} n ps -> do | ||
620 | (fn, tn) <- lookEnv n $ lift $ throwErrorTCM $ "Constructor" <+> pShow n <+> "is not in scope." | ||
621 | v <- case getRes (length ps) tn of | ||
622 | Just (ts, x) -> do | ||
623 | addUnifs True $ zipWith (\a b -> [a, b]) ts $ map (tyOfPat . fst) ps | ||
624 | return x | ||
625 | _ -> do | ||
626 | v <- newStarVar "pcon" | ||
627 | addUnif tn $ map (tyOfPat . fst) ps ~~> v | ||
628 | return v | ||
629 | return (PCon v n $ [Pat $ PVar_ t n | TVar t n <- fn] ++ (fst <$> ps), mempty) | ||
630 | |||
631 | _ -> do | ||
632 | (t, tr) <- case tyOfPat . fst <$> p of | ||
633 | Wildcard_ _{-TODO-} -> noTr $ newStarVar ("_p" <> pShow pt) >>= pure | ||
634 | |||
635 | PAt_ n p -> return (error "impossible patty", monoInstType n p) | ||
636 | |||
637 | PTuple_ ps -> {-mapM_ checkStarKind (map tyOf ps) >> -}return (error "impossible patty", mempty) | ||
638 | |||
639 | PRecord_ (unzip -> (fs, ps)) -> noTr $ do | ||
640 | v <- newStarVar "pfp2" | ||
641 | v' <- newStarVar "pfp3" | ||
642 | addConstraint $ Split v v' $ TRecord $ Map.fromList $ zip fs ps | ||
643 | return v | ||
644 | |||
645 | _ -> return (error "impossible patty", mempty) | ||
646 | return (Pat $ mapPat (const t) id id $ fst <$> p, tr) | ||
647 | |||
648 | let trs = Map.unionsWith (++) . map ((:[]) <$>) $ tr: map snd (toList p) | ||
649 | tr <- case filter (not . null . drop 1 . snd) $ Map.toList trs of | ||
650 | [] -> return $ Map.map head trs | ||
651 | ns -> lift $ throwErrorTCM $ "conflicting definitions for" <+> pShow (map fst ns) | ||
652 | return (res, tr) | ||
653 | where | ||
654 | noTr = addTr $ const mempty | ||
655 | addTr tr m = (\x -> (x, tr x)) <$> m | ||
656 | |||
657 | eLam' (n, t) e = Exp $ ELam_ (Just $ Exp $ Forall_ Hidden (Just n) t $ tyOf e) (PVar t n) e | ||
658 | |||
659 | inferType = inferType_ True True | ||
660 | inferTyping = inferType_ True False | ||
661 | |||
662 | info (Range i j) x = tell [(i, j, ppShow x)] | ||
663 | info _ x = return () | ||
664 | |||
665 | withSE = mapWriterT' $ fmap $ \(se, x) -> (se, (se, x)) | ||
666 | |||
667 | addRange' msg = addRangeBy' msg id | ||
668 | addRangeBy' msg f r m = addRange r $ do | ||
669 | (se, x) <- withSE m | ||
670 | addRange_ msg r se $ f x | ||
671 | return x | ||
672 | |||
673 | addRangeBy f r m = addRange r $ do | ||
674 | x <- m | ||
675 | info r =<< typingToTy' (f x) | ||
676 | return x | ||
677 | |||
678 | addRange_ msg r se x = info r =<< typingToTy msg se (tyOf x) | ||
679 | |||
680 | unWhereAlts :: GuardTree Exp -> Maybe (Binds Exp, [GuardTree Exp]) | ||
681 | unWhereAlts = f [] where | ||
682 | f acc = \case | ||
683 | GuardWhere bs t -> f (acc ++ bs) t | ||
684 | GuardAlts xs -> g acc xs | ||
685 | x -> Just (acc, [x]) | ||
686 | |||
687 | g acc [] = Nothing | ||
688 | g acc (x: xs) = case unWhereAlts x of | ||
689 | Nothing -> g acc xs | ||
690 | Just (wh, ts) -> Just (acc ++ wh, ts ++ xs) | ||
691 | |||
692 | undef :: Exp | ||
693 | undef = eVar mempty $ ExpN "undefined" | ||
694 | |||
695 | where_ :: Binds Exp -> Exp -> Exp | ||
696 | where_ bs a = foldr ($) a [ELet p e | (p, e) <- bs] | ||
697 | |||
698 | contable :: ConName -> TCMS [(ConName, Int)] | ||
699 | contable (TupleName i) = return [(TupleName i, i)] | ||
700 | contable (ConName n) = asks (Map.lookup n . constructors) >>= \case | ||
701 | Nothing -> error $ "contable: " ++ ppShow n | ||
702 | Just x -> return $ map (ConName *** id) x | ||
703 | |||
704 | |||
705 | guardNode :: Exp -> ParPat Exp -> GuardTree Exp -> GuardTree Exp | ||
706 | guardNode v [] e = e | ||
707 | guardNode v (w: ws) e = case w of | ||
708 | PatVar x -> guardNode v ws {-(subst d ws)-} $ subst d e | ||
709 | where d = Subst $ Map.singleton x v | ||
710 | ViewPat f p -> guardNode (eApp f v) p $ guardNode v ws e | ||
711 | PatCon s ps' -> GuardCon v s ps' $ guardNode v ws e | ||
712 | PatLit l -> GuardCon (compareLit l v) (ConName $ ExpN "EQ") [] $ guardNode v ws e | ||
713 | PatPrec p ps -> error $ "guardNode: " ++ ppShow (p, ps) | ||
714 | |||
715 | compareLit :: Lit -> Exp -> Exp | ||
716 | compareLit l e = eApp (Exp $ PrimFun (inferLit l ~> Ordering) n [ELit l] 1) e where | ||
717 | n = case l of | ||
718 | LInt{} -> ExpN "primCompareInt" | ||
719 | LFloat{} -> ExpN "primCompareFloat" | ||
720 | LNat{} -> ExpN "primCompareNat" | ||
721 | LString{} -> ExpN "primCompareString" | ||
722 | |||
723 | computePatPrec t = do | ||
724 | precs <- asks precedences | ||
725 | let | ||
726 | f = \case | ||
727 | GuardPat e p t -> guardNode e <$> comp p <*> f t | ||
728 | GuardCon e n ps t -> GuardCon e n <$> mapM comp ps <*> f t | ||
729 | GuardWhere bs t -> GuardWhere bs <$> f t | ||
730 | GuardAlts ts -> GuardAlts <$> mapM f ts | ||
731 | GuardExp e -> return $ GuardExp e | ||
732 | -- comp :: ParPat Exp -> ParPat Exp | ||
733 | comp = concatMapM $ \case | ||
734 | PatVar n -> return [PatVar n] | ||
735 | PatLit n -> return [PatLit n] | ||
736 | PatCon n ps -> (:[]) . PatCon n <$> mapM comp ps | ||
737 | ViewPat e p -> (:[]) . ViewPat e <$> comp p | ||
738 | -- PatPrec e es | any null (e: map snd es) -> return [] | ||
739 | PatPrec e es -> do | ||
740 | e' <- comp e | ||
741 | es' <- mapM (\(a,b) -> (,) <$> comp a <*> comp b) es | ||
742 | calcPrec (\a b c -> appP' a [b, c]) (\[PatCon (ConName n) []] -> n) precs e' es' | ||
743 | |||
744 | appP' [PatCon n []] ps = [PatCon n ps] | ||
745 | appP' p ps = error $ "appP' " ++ ppShow (p, ps) | ||
746 | |||
747 | in f t | ||
748 | |||
749 | concatMapM f x = concat <$> mapM f x | ||
750 | |||
751 | -- TODO: eliminate | ||
752 | case_ :: Exp -> [(ConName, [Name], Exp)] -> Maybe Exp | ||
753 | case_ e [] = Nothing | ||
754 | case_ e as = Just $ {- Exp $ Case_ TWildcard e -} compileCasesOld mempty e | ||
755 | [ (case c of | ||
756 | TupleName i -> PatR mempty $ PTuple_ vs | ||
757 | ConName c -> PCon' mempty c vs | ||
758 | , e) | ||
759 | | (c, ns, e) <- as | ||
760 | , let vs = map (PVar' mempty) ns | ||
761 | ] | ||
762 | |||
763 | guardTreeToCases :: GuardTree Exp -> TCMS (Maybe{-workaround-} Exp) | ||
764 | guardTreeToCases t = case unWhereAlts t of | ||
765 | Nothing -> return Nothing | ||
766 | Just (wh, GuardExp e: _) -> return $ Just $ where_ wh e | ||
767 | Just (wh, cs@(GuardCon f s _ _: _)) -> do | ||
768 | ct <- contable s | ||
769 | fmap (where_ wh) . case_ f . catMaybes <$> sequence | ||
770 | [ do | ||
771 | ns <- forM [1..cv] $ \j -> newName $ "cparam" <> pShow j <> "_" | ||
772 | fmap (fmap ((,,) cn ns)) $ guardTreeToCases $ GuardAlts $ map (filterGuardTree f cn ns) cs | ||
773 | | (cn, cv) <- ct | ||
774 | ] | ||
775 | e -> error $ "gtc: " ++ ppShow e | ||
776 | |||
777 | filterGuardTree :: Exp -> ConName -> [Name] -> GuardTree Exp -> GuardTree Exp | ||
778 | filterGuardTree f s ns = \case | ||
779 | GuardWhere bs t -> GuardWhere bs $ filterGuardTree f s ns t -- TODO: shadowing | ||
780 | GuardAlts ts -> GuardAlts $ map (filterGuardTree f s ns) ts | ||
781 | GuardExp e -> GuardExp e | ||
782 | GuardCon f' s' ps gs | ||
783 | | f /= f' -> GuardCon f' s' ps $ filterGuardTree f s ns gs | ||
784 | | s == s' -> filterGuardTree f s ns $ guardNodes' (zip (map (eVar mempty) ns) ps) gs | ||
785 | | otherwise -> GuardAlts [] | ||
786 | |||
787 | guardNodes' :: [(Exp, ParPat Exp)] -> GuardTree Exp -> GuardTree Exp | ||
788 | guardNodes' [] l = l | ||
789 | guardNodes' ((v, ws): vs) e = guardNode v ws $ guardNodes' vs e | ||
790 | |||
791 | compileAlts :: Int -> [([ParPat Exp], GuardTree Exp)] -> TCMS Exp | ||
792 | compileAlts i as = do | ||
793 | vs <- forM [1..i] $ \j -> newName $ "param" <> pShow j <> "_" | ||
794 | flip (foldr eLam) (map (pVar mempty) vs) <$> (computePatPrec >=> fmap (fromMaybe undef) . guardTreeToCases) (toGuardTree (map (eVar mempty) vs) as) | ||
795 | |||
796 | inferType_ :: Bool -> Bool -> ExpR -> TCMS Exp | ||
797 | inferType_ addcst allowNewVar e_@(ExpR r e) = addRange' (pShow e_) r $ addCtx ("type inference of" <+> pShow e) $ appSES $ case e of | ||
798 | FunAlts_ i as -> infer =<< compileAlts i as | ||
799 | |||
800 | EPrec_ e es -> do | ||
801 | ps <- asks precedences | ||
802 | infer =<< calcPrec (\a b c -> application [a, b, c]) (\(EVarR' _ n) -> n) ps e es | ||
803 | -- hack | ||
804 | ENamedRecord_ n (unzip -> (fs, es)) -> | ||
805 | inferTyping $ foldl (EAppR' mempty) (EVarR' mempty n) es | ||
806 | |||
807 | Case_ TWildcard e cs -> do | ||
808 | e <- infer e | ||
809 | cs <- forM cs $ \(p, f) -> do | ||
810 | (se, (p, tr)) <- lift $ runWriterT' $ inferPatTyping False p | ||
811 | addConstraints se | ||
812 | f <- addCtx "?" $ withTyping (tr <> (tyOfItem <$> getTEnv se)) $ inferTyping f | ||
813 | return (p, f) | ||
814 | let te = tyOf e | ||
815 | tp = map (\(p, x) -> tyOfPat p ~> tyOf x) cs | ||
816 | addUnifs True [tp] | ||
817 | t <- appTy (head tp) te | ||
818 | return $ Exp $ Case_ t e cs | ||
819 | |||
820 | ELam_ h p f -> {-mapWriterT' (fmap $ \(se, x) -> trace (" -- " ++ ppShow p ++ ppShow se) (se, x) ) $ -} do | ||
821 | h <- traverse infer h | ||
822 | (se, (p, tr)) <- lift $ runWriterT' $ inferPatTyping False p | ||
823 | addConstraints se | ||
824 | f <- addCtx "?" $ withTyping (tr <> (tyOfItem <$> getTEnv se)) $ inferTyping f | ||
825 | case h of | ||
826 | Just t -> removeMonoVars $ do | ||
827 | n <- newName $ "?" <> pShow p <> pShow r | ||
828 | let t' = Exp $ Forall_ Hidden (Just n) (tyOfPat p) (tyOf f) | ||
829 | tp = tyOfPat p | ||
830 | addUnif t t' | ||
831 | singSubstTy n tp | ||
832 | return (Set.singleton n, Exp $ ELam_ (Just t') p f) | ||
833 | Nothing -> return $ Exp $ ELam_ Nothing p f | ||
834 | |||
835 | ELet_ p@(PVar' _ n) x_ e -> do | ||
836 | (se, x) <- lift $ do | ||
837 | (se, x) <- runWriterT'' $ inferTyping x_ | ||
838 | let (se', se'') = splitEnv se | ||
839 | (fs, it) <- addRange (getTag x_) $ addCtx "let" $ instantiateTyping_' True (pShow n) se' $ tyOf x | ||
840 | return (se'', foldr eLam' x fs) | ||
841 | -- addRange_ ("var" <+> pShow n) (getTag p `mappend` getTag x_) se x | ||
842 | addConstraints $ TEnv $ Map.filter (eitherItem (\r -> const $ not r) (\_ -> const False)) $ getTEnv se | ||
843 | e <- withTyping (Map.singleton n $ tyOf x) $ inferTyping e | ||
844 | return $ ELet (PVar (tyOf x) n) x e | ||
845 | ELet_ p x e -> infer $ ExpR mempty $ EApp_ TWildcard (ExpR mempty $ ELam_ Nothing p e) x -- monomorph let; TODO | ||
846 | ETypeSig_ e ty -> do | ||
847 | e <- inferTyping e | ||
848 | ty <- inferType ty | ||
849 | addUnifOneDir (tyOf e) ty | ||
850 | return e | ||
851 | ETyApp_ TWildcard f t -> do | ||
852 | f <- inferTyping f | ||
853 | t <- inferType t | ||
854 | v <- forallApp (tyOf f) t | ||
855 | return $ TApp v f t | ||
856 | |||
857 | Forall_ h (Just n) k t -> removeMonoVars $ do | ||
858 | k <- inferType k | ||
859 | singSubstTy n k | ||
860 | t <- withTyping (monoInstType n k) $ inferType t | ||
861 | return $ (,) (Set.fromList [n]) $ Exp $ Forall_ h (Just n) k t | ||
862 | |||
863 | EVar_ TWildcard n -> do | ||
864 | (ty, t) <- lookEnv n $ if allowNewVar | ||
865 | then newStarVar' "tvar" n >>= \t -> return ([], t) | ||
866 | else throwErrorTCM $ "Variable" <+> pShow n <+> "is not in scope." | ||
867 | return $ buildApp (`TVar` n) t ty | ||
868 | |||
869 | TCon_ TWildcard n -> do | ||
870 | (fn, t) <- lookEnv n $ lookLifted $ throwErrorTCM $ "Type constructor" <+> pShow n <+> "is not in scope." | ||
871 | return $ buildApp (Exp . (`TCon_` n)) t fn | ||
872 | where | ||
873 | lookLifted = if isTypeVar n then lookEnv (toExpN n) else id | ||
874 | |||
875 | EApp_ TWildcard tf_ ta_ -> do | ||
876 | tf <- infer tf_ | ||
877 | ta <- infer ta_ | ||
878 | t <- appTy (tyOf tf) (tyOf ta) | ||
879 | return $ Exp $ EApp_ t tf ta | ||
880 | |||
881 | TWildcard_ -> newStarVar $ "_e" <> pShow r | ||
882 | |||
883 | _ -> do | ||
884 | e <- mapExp_ id (error "infertype") <$> traverse infer e | ||
885 | case e of | ||
886 | EFieldProj_ t fn -> do | ||
887 | a <- newStarVar "fp1" | ||
888 | r <- newStarVar "fp2" | ||
889 | r' <- newStarVar "fp3" | ||
890 | addConstraint $ Split r r' $ TRecord $ Map.singleton (IdN fn) a | ||
891 | addUnif t $ r ~> a | ||
892 | |||
893 | EAlts_ xs -> addUnifs True [map tyOf xs] | ||
894 | TTuple_ ts -> mapM_ checkStarKind ts | ||
895 | |||
896 | CEq_ (tyOf -> t) (TypeFun f (map tyOf -> ts)) -> do | ||
897 | (_, tf) <- lookEnv' f $ throwErrorTCM $ "Type family" <+> pShow f <+> "is not in scope." | ||
898 | addUnif tf $ ts ~~> t | ||
899 | |||
900 | Forall_ _ Nothing a b -> checkStarKind a >> checkStarKind b | ||
901 | |||
902 | x -> return () | ||
903 | case e of | ||
904 | Forall_ (hidden -> True) Nothing c b | addcst -> do | ||
905 | addConstraint c | ||
906 | return b | ||
907 | e -> return $ Exp e | ||
908 | where | ||
909 | infer = inferType_ addcst allowNewVar | ||
910 | |||
911 | -------------------------------------------------------------------------------- | ||
912 | |||
913 | tyConKind :: [ExpR] -> TCM Exp | ||
914 | tyConKind = tyConKind_ $ ExpR mempty Star_ | ||
915 | |||
916 | tyConKind_ :: ExpR -> [ExpR] -> TCM Exp | ||
917 | tyConKind_ res vs = instantiateTyping "tyconkind" $ inferType $ foldr (\a b -> ExpR' $ Forall_ Visible Nothing a b) res vs | ||
918 | |||
919 | inferConDef :: Name -> [(Name, ExpR)] -> WithRange ConDef -> TCM InstEnv | ||
920 | inferConDef con ks (r, ConDef n tys) = addRange r $ do | ||
921 | ty <- instantiateTyping (pShow con) $ inferType $ foldr | ||
922 | (\(vn, vt) b -> ExpR' $ Forall_ Irrelevant (Just vn) vt b) | ||
923 | (foldr (\a b -> ExpR' (Forall_ Visible Nothing a b)) (tyConResTy con $ map fst ks) [t | FieldTy _ t <- tys]) | ||
924 | ks | ||
925 | return $ Map.singleton n ty | ||
926 | |||
927 | inferConDef' :: Name -> [(Name, ExpR)] -> WithRange (Name, ConDef') -> TCM InstEnv | ||
928 | inferConDef' con ks (r, (n, ConDef' ctx tys res)) = addRange r $ do | ||
929 | ty <- instantiateTyping (pShow con) $ inferType $ {-foldr | ||
930 | (\(vn, vt) b -> ExpR' $ Forall_ Irrelevant (Just vn) vt b)-} | ||
931 | (foldr | ||
932 | (\(n, a) b -> ExpR' (maybe (Forall_ Hidden Nothing) (Forall_ Visible . Just) n a b)) | ||
933 | (foldr (\a b -> ExpR' (Forall_ Visible Nothing a b)) res [t | FieldTy _ t <- tys]) | ||
934 | ctx | ||
935 | ) | ||
936 | {- $ filter (not . (`elem` map fst ctx) . Just . fst) | ||
937 | ks -} | ||
938 | return $ Map.singleton n ty | ||
939 | |||
940 | tyConResTy con vn | ||
941 | = application $ (ExpR' $ TCon_ TWildcard con): map (ExpR' . EVar_ TWildcard) vn | ||
942 | tyConResTy' con vn | ||
943 | = application $ (ExpR' $ TCon_ TWildcard con): vn | ||
944 | |||
945 | selectorDefs :: DefinitionR -> [DefinitionR] | ||
946 | selectorDefs (r, DDataDef n _ cs) = | ||
947 | [ (r, DValueDef False $ ValueDef False | ||
948 | ( PatR' $ PVar_ TWildcard sel) | ||
949 | ( ExpR' $ ELam_ (if ctx then Just TWildcard else Nothing) | ||
950 | (PatR' $ PCon_ TWildcard cn | ||
951 | [ if i == j then PVar' mempty (ExpN "x") else PatR mempty (Wildcard_ TWildcard) | ||
952 | | (j, _) <- zip [0..] tys] | ||
953 | ) | ||
954 | (EVarR' mempty $ ExpN "x") | ||
955 | )) | ||
956 | | (rc, ConDef cn tys) <- cs | ||
957 | , (i, FieldTy (Just (sel, ctx)) t) <- zip [0..] tys | ||
958 | ] | ||
959 | selectorDefs (r, GADT n _ cs) = | ||
960 | [ (r, DValueDef False $ ValueDef False | ||
961 | ( PatR' $ PVar_ TWildcard sel) | ||
962 | ( ExpR' $ ELam_ (if ctx then Just TWildcard else Nothing) | ||
963 | (PatR' $ PCon_ TWildcard cn | ||
964 | [ if i == j then PVar' mempty (ExpN "x") else PatR mempty (Wildcard_ TWildcard) | ||
965 | | (j, _) <- zip [0..] tys] | ||
966 | ) | ||
967 | (EVarR' mempty $ ExpN "x") | ||
968 | )) | ||
969 | | (rc, (cn, ConDef' _ctx' tys _res)) <- cs | ||
970 | , (i, FieldTy (Just (sel, ctx)) t) <- zip [0..] tys | ||
971 | ] | ||
972 | |||
973 | --inferDef :: ValueDefR -> TCM (TCM a -> TCM a) | ||
974 | inferDef (ValueDef True p e) | ||
975 | = inferDef $ ValueDef False p $ application [EVarR' mempty fixName, ExpR' $ ELam_ Nothing p e] | ||
976 | inferDef (ValueDef False p@(PVar' _ n) e) = do | ||
977 | (se, exp) <- runWriterT' $ inferTyping e | ||
978 | (fs, f) <- addCtx ("inst" <+> pShow p) $ instantiateTyping_' True (pShow p) se $ tyOf exp | ||
979 | the <- asks getPolyEnv | ||
980 | let th = subst ( toSubst (TEnv the) | ||
981 | ) | ||
982 | $ flip (foldr eLam') fs exp | ||
983 | return (n, th) | ||
984 | inferDef (ValueDef _ p e) = error $ "inferDef: " ++ ppShow p | ||
985 | |||
986 | classDictName = toExpN . addPrefix "Dict" | ||
987 | |||
988 | withThunk n th = addPolyEnv $ emptyPolyEnv {getPolyEnv = Map.singleton n $ ISubst True th} | ||
989 | |||
990 | inferDefs :: [DefinitionR] -> TCM PolyEnv | ||
991 | inferDefs [] = ask | ||
992 | inferDefs (dr@(r, d): ds@(inferDefs -> cont)) = {-addRange r $ -}case d of | ||
993 | PrecDef n p -> addPolyEnv (emptyPolyEnv {precedences = Map.singleton n p}) cont | ||
994 | DValueDef inst d -> do | ||
995 | (n, th) <- addRangeBy (\(_,th) -> envType *** id $ toEnvType $ tyOf th) r $ inferDef d | ||
996 | withThunk n th . (if inst then addInstance n $ tyOf th else id) $ cont | ||
997 | TypeFamilyDef con vars res -> do | ||
998 | tk <- tyConKind_ res $ map snd vars | ||
999 | addPolyEnv (emptyPolyEnv {typeFamilies = Map.singleton con tk}) cont | ||
1000 | DAxiom (TypeSig n t) -> do | ||
1001 | t <- instantiateTyping (pShow n) $ inferType t | ||
1002 | let res (Exp (Forall_ _ _ a b)) = res b | ||
1003 | res t = t | ||
1004 | n' = (if isStar $ res t then toTypeN else id) n | ||
1005 | isPrim (ExpN s) = take 4 s `elem` ["prim", "Prim"] | ||
1006 | arity = f t where | ||
1007 | f (Exp (Forall_ h _ _ x)) = (case h of Visible -> 1; _ -> 0) + f x | ||
1008 | f _ = 0 | ||
1009 | f | isPrim n = withThunk n $ Exp $ PrimFun t n [] arity | ||
1010 | | otherwise = withTyping $ Map.singleton n' t | ||
1011 | f cont | ||
1012 | GADT con vars cdefs -> do | ||
1013 | tk <- tyConKind $ map snd vars | ||
1014 | let as = [(n, length ps) | (_, (n, ConDef' _ ps _)) <- cdefs] | ||
1015 | withTyping (Map.singleton con tk) $ addPolyEnv (emptyPolyEnv {constructors = Map.fromList $ zip (map fst as) $ repeat as }) $ do | ||
1016 | ev <- mapM (inferConDef' con vars) cdefs | ||
1017 | withTyping (mconcat ev) $ inferDefs $ selectorDefs dr ++ ds | ||
1018 | DDataDef con vars cdefs -> do | ||
1019 | tk <- tyConKind $ map snd vars | ||
1020 | let as = [(n, length ps) | (_, ConDef n ps) <- cdefs] | ||
1021 | withTyping (Map.singleton con tk) $ addPolyEnv (emptyPolyEnv {constructors = Map.fromList $ zip (map fst as) $ repeat as }) $ do | ||
1022 | ev <- mapM (inferConDef con vars) cdefs | ||
1023 | withTyping (mconcat ev) $ inferDefs $ selectorDefs dr ++ ds | ||
1024 | |||
1025 | ClassDef ctx{-TODO-} con vars cdefs -> inferDefs $ (r, d'): ds | ||
1026 | where | ||
1027 | d' = DDataDef con vars | ||
1028 | [WithRange mempty $ ConDef (classDictName con) [FieldTy (Just (n, True)) t | TypeSig n t <- cdefs]] | ||
1029 | |||
1030 | InstanceDef ctx con vars xs -> inferDefs $ (r, d'): ds | ||
1031 | where | ||
1032 | iname = addPrefix "instance" $ ExpN $ ppShow $ application $ ExpR' (EVar_ TWildcard con): vars | ||
1033 | d' = DValueDef True $ ValueDef True (PatR' $ PVar_ TWildcard iname) $ | ||
1034 | ExpR' $ ETypeSig_ | ||
1035 | (application $ (ExpR' $ EVar_ TWildcard $ classDictName con): [e | ValueDef _ (PVar' _ n{-TODO-}) e <- xs]) | ||
1036 | (tyConResTy' con vars) | ||
1037 | |||
1038 | _ -> error $ "inferDefs: " ++ ppShow d | ||
1039 | |||
1040 | inference_ :: PolyEnv -> ModuleR -> ErrorT (WriterT Infos (VarMT Identity)) PolyEnv | ||
1041 | inference_ penv@PolyEnv{..} Module{..} = do | ||
1042 | resetVars | ||
1043 | ExceptT $ mapWriterT (fmap $ (id +++ diffEnv) *** id) (runExceptT $ flip runReaderT penv $ addPolyEnv startPolyEnv $ inferDefs definitions) | ||
1044 | where | ||
1045 | diffEnv (PolyEnv i g c p tf _) = PolyEnv | ||
1046 | (Map.differenceWith (\a b -> Just $ a Map.\\ b) i instanceDefs) | ||
1047 | (g Map.\\ getPolyEnv) | ||
1048 | (c Map.\\ constructors) | ||
1049 | (p Map.\\ precedences) | ||
1050 | (tf Map.\\ typeFamilies) | ||
1051 | mempty --infos | ||
1052 | |||
diff --git a/prototypes/create-test-report.sh b/create-test-report.sh index 4d26467a..4d26467a 100755 --- a/prototypes/create-test-report.sh +++ b/create-test-report.sh | |||
diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal index 7ce26001..89ff5798 100644 --- a/lambdacube-compiler.cabal +++ b/lambdacube-compiler.cabal | |||
@@ -2,40 +2,36 @@ | |||
2 | -- documentation, see http://haskell.org/cabal/users-guide/ | 2 | -- documentation, see http://haskell.org/cabal/users-guide/ |
3 | 3 | ||
4 | name: lambdacube-compiler | 4 | name: lambdacube-compiler |
5 | version: 0.1.0.0 | 5 | version: 0.2.0.0 |
6 | -- synopsis: | ||
7 | -- description: | ||
8 | homepage: lambdacube3d.com | 6 | homepage: lambdacube3d.com |
9 | license: BSD3 | 7 | license: BSD3 |
10 | license-file: LICENSE | 8 | license-file: LICENSE |
11 | author: Csaba Hruska, Peter Divianszky | 9 | author: Csaba Hruska, Peter Divianszky |
12 | maintainer: csaba.hruska@gmail.com | 10 | maintainer: csaba.hruska@gmail.com |
13 | -- copyright: | ||
14 | category: Graphics | 11 | category: Graphics |
15 | build-type: Simple | 12 | build-type: Simple |
16 | -- extra-source-files: | ||
17 | cabal-version: >=1.10 | 13 | cabal-version: >=1.10 |
18 | 14 | ||
15 | Flag profiling | ||
16 | Description: Enable profiling | ||
17 | Default: False | ||
18 | |||
19 | library | 19 | library |
20 | -- indentation parser modules | 20 | -- indentation parser modules |
21 | exposed-modules: Text.Parser.Indentation.Implementation, | 21 | exposed-modules: Text.Parser.Indentation.Implementation, |
22 | Text.Parsec.Indentation, | 22 | Text.Parsec.Indentation, |
23 | Text.Parsec.Indentation.Char, | 23 | Text.Parsec.Indentation.Char, |
24 | Text.Parsec.Indentation.Token | 24 | Text.Parsec.Indentation.Token |
25 | |||
26 | exposed-modules: | 25 | exposed-modules: |
27 | -- Compiler | 26 | -- Compiler |
28 | Pretty | 27 | Pretty |
29 | Type | ||
30 | Typecheck | ||
31 | Parser | ||
32 | ParserUtil | ||
33 | IR | 28 | IR |
34 | Linear | 29 | Linear |
35 | CoreToIR | 30 | CoreToIR |
36 | CoreToGLSL | 31 | CoreToGLSL |
32 | Infer | ||
33 | CGExp | ||
37 | Driver | 34 | Driver |
38 | -- other-modules: | ||
39 | other-extensions: | 35 | other-extensions: |
40 | LambdaCase | 36 | LambdaCase |
41 | PatternSynonyms | 37 | PatternSynonyms |
@@ -57,28 +53,41 @@ library | |||
57 | ParallelListComp | 53 | ParallelListComp |
58 | build-depends: | 54 | build-depends: |
59 | -- compiler | 55 | -- compiler |
56 | aeson >= 0.9 && <1, | ||
60 | base >=4.7 && <4.9, | 57 | base >=4.7 && <4.9, |
61 | containers >=0.5 && <0.6, | 58 | containers >=0.5 && <0.6, |
59 | deepseq, | ||
62 | directory, | 60 | directory, |
61 | exceptions >= 0.8 && <0.9, | ||
63 | filepath, | 62 | filepath, |
64 | mtl >=2.2 && <2.3, | 63 | mtl >=2.2 && <2.3, |
65 | parsec >= 3.1 && <3.2, | 64 | parsec >= 3.1 && <3.2, |
66 | pretty-compact >=1.0 && <1.1, | 65 | pretty-compact >=1.0 && <1.1, |
67 | exceptions >= 0.8 && <0.9, | 66 | text >= 1.2 && <1.3, |
68 | deepseq, | 67 | vector >= 0.11 && <0.12 |
69 | vector >= 0.11 && <0.12, | ||
70 | aeson >= 0.9 && <1, | ||
71 | text >= 1.2 && <1.3 | ||
72 | hs-source-dirs: . | 68 | hs-source-dirs: . |
73 | default-language: Haskell2010 | 69 | default-language: Haskell2010 |
74 | 70 | ||
75 | --test-suite runtests | 71 | executable lambdacube-compiler-test-suite |
76 | -- type: exitcode-stdio-1.0 | 72 | hs-source-dirs: . |
77 | -- hs-source-dirs: tests | 73 | main-is: runTests.hs |
78 | -- main-is: runTests.hs | 74 | |
79 | -- | 75 | build-depends: |
80 | -- build-depends: base < 4.9 | 76 | aeson >= 0.9 && <1, |
81 | -- , filepath | 77 | base < 4.9, |
82 | -- , directory | 78 | containers >=0.5 && <0.6, |
83 | -- , lambdacube-dsl | 79 | deepseq, |
84 | -- default-language: Haskell2010 | 80 | directory, |
81 | exceptions >= 0.8 && <0.9, | ||
82 | filepath, | ||
83 | mtl >=2.2 && <2.3, | ||
84 | lambdacube-compiler, | ||
85 | parsec >= 3.1 && <3.2, | ||
86 | pretty-compact >=1.0 && <1.1, | ||
87 | text >= 1.2 && <1.3, | ||
88 | vector >= 0.11 && <0.12 | ||
89 | default-language: Haskell2010 | ||
90 | if flag(profiling) | ||
91 | GHC-Options: -O2 -fhpc -hpcdir dist/hpc/lambdacube-compiler -prof -fprof-auto -rtsopts | ||
92 | else | ||
93 | GHC-Options: -O2 -fhpc -hpcdir dist/hpc/lambdacube-compiler | ||
diff --git a/prototypes/CoreToGLSL.hs b/prototypes/CoreToGLSL.hs deleted file mode 120000 index b9ebdd27..00000000 --- a/prototypes/CoreToGLSL.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../CoreToGLSL.hs \ No newline at end of file | ||
diff --git a/prototypes/CoreToIR.hs b/prototypes/CoreToIR.hs deleted file mode 120000 index 7f32ac4d..00000000 --- a/prototypes/CoreToIR.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../CoreToIR.hs \ No newline at end of file | ||
diff --git a/prototypes/Driver.hs b/prototypes/Driver.hs deleted file mode 120000 index 882f3164..00000000 --- a/prototypes/Driver.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../Driver.hs \ No newline at end of file | ||
diff --git a/prototypes/IR.hs b/prototypes/IR.hs deleted file mode 120000 index ae04b92e..00000000 --- a/prototypes/IR.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../IR.hs \ No newline at end of file | ||
diff --git a/prototypes/Linear.hs b/prototypes/Linear.hs deleted file mode 120000 index 5f80cf33..00000000 --- a/prototypes/Linear.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../Linear.hs \ No newline at end of file | ||
diff --git a/prototypes/Parser.hs b/prototypes/Parser.hs deleted file mode 100644 index 75a3a722..00000000 --- a/prototypes/Parser.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | module Parser where | ||
diff --git a/prototypes/Pretty.hs b/prototypes/Pretty.hs deleted file mode 120000 index eb36e481..00000000 --- a/prototypes/Pretty.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../Pretty.hs \ No newline at end of file | ||
diff --git a/prototypes/Text b/prototypes/Text deleted file mode 120000 index 4ea788ba..00000000 --- a/prototypes/Text +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../Text \ No newline at end of file | ||
diff --git a/prototypes/Type.hs b/prototypes/Type.hs deleted file mode 100644 index 8e1e6af5..00000000 --- a/prototypes/Type.hs +++ /dev/null | |||
@@ -1,2 +0,0 @@ | |||
1 | module Type ( module CGExp ) where | ||
2 | import CGExp | ||
diff --git a/prototypes/Typecheck.hs b/prototypes/Typecheck.hs deleted file mode 100644 index dc82a9a0..00000000 --- a/prototypes/Typecheck.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | module Typecheck where | ||
diff --git a/prototypes/lambdacube-compiler.cabal b/prototypes/lambdacube-compiler.cabal deleted file mode 100644 index 76d26c98..00000000 --- a/prototypes/lambdacube-compiler.cabal +++ /dev/null | |||
@@ -1,96 +0,0 @@ | |||
1 | -- Initial lambdacube-dsl.cabal generated by cabal init. For further | ||
2 | -- documentation, see http://haskell.org/cabal/users-guide/ | ||
3 | |||
4 | name: lambdacube-compiler | ||
5 | version: 0.2.0.0 | ||
6 | homepage: lambdacube3d.com | ||
7 | license: BSD3 | ||
8 | license-file: LICENSE | ||
9 | author: Csaba Hruska, Peter Divianszky | ||
10 | maintainer: csaba.hruska@gmail.com | ||
11 | category: Graphics | ||
12 | build-type: Simple | ||
13 | cabal-version: >=1.10 | ||
14 | |||
15 | Flag profiling | ||
16 | Description: Enable profiling | ||
17 | Default: False | ||
18 | |||
19 | library | ||
20 | -- indentation parser modules | ||
21 | exposed-modules: Text.Parser.Indentation.Implementation, | ||
22 | Text.Parsec.Indentation, | ||
23 | Text.Parsec.Indentation.Char, | ||
24 | Text.Parsec.Indentation.Token | ||
25 | exposed-modules: | ||
26 | -- Compiler | ||
27 | Pretty | ||
28 | Type | ||
29 | Typecheck | ||
30 | Parser | ||
31 | IR | ||
32 | Linear | ||
33 | CoreToIR | ||
34 | CoreToGLSL | ||
35 | Infer | ||
36 | CGExp | ||
37 | Driver | ||
38 | other-extensions: | ||
39 | LambdaCase | ||
40 | PatternSynonyms | ||
41 | ViewPatterns | ||
42 | TypeSynonymInstances | ||
43 | FlexibleInstances | ||
44 | NoMonomorphismRestriction | ||
45 | TypeFamilies | ||
46 | RecordWildCards | ||
47 | DeriveFunctor | ||
48 | DeriveFoldable | ||
49 | DeriveTraversable | ||
50 | GeneralizedNewtypeDeriving | ||
51 | OverloadedStrings | ||
52 | TupleSections | ||
53 | MonadComprehensions | ||
54 | ExistentialQuantification | ||
55 | ScopedTypeVariables | ||
56 | ParallelListComp | ||
57 | build-depends: | ||
58 | -- compiler | ||
59 | aeson >= 0.9 && <1, | ||
60 | base >=4.7 && <4.9, | ||
61 | containers >=0.5 && <0.6, | ||
62 | deepseq, | ||
63 | directory, | ||
64 | exceptions >= 0.8 && <0.9, | ||
65 | filepath, | ||
66 | mtl >=2.2 && <2.3, | ||
67 | parsec >= 3.1 && <3.2, | ||
68 | pretty-compact >=1.0 && <1.1, | ||
69 | text >= 1.2 && <1.3, | ||
70 | vector >= 0.11 && <0.12 | ||
71 | hs-source-dirs: . | ||
72 | default-language: Haskell2010 | ||
73 | |||
74 | executable lambdacube-compiler-test-suite | ||
75 | hs-source-dirs: . | ||
76 | main-is: runTests.hs | ||
77 | |||
78 | build-depends: | ||
79 | aeson >= 0.9 && <1, | ||
80 | base < 4.9, | ||
81 | containers >=0.5 && <0.6, | ||
82 | deepseq, | ||
83 | directory, | ||
84 | exceptions >= 0.8 && <0.9, | ||
85 | filepath, | ||
86 | mtl >=2.2 && <2.3, | ||
87 | lambdacube-compiler, | ||
88 | parsec >= 3.1 && <3.2, | ||
89 | pretty-compact >=1.0 && <1.1, | ||
90 | text >= 1.2 && <1.3, | ||
91 | vector >= 0.11 && <0.12 | ||
92 | default-language: Haskell2010 | ||
93 | if flag(profiling) | ||
94 | GHC-Options: -O2 -fhpc -hpcdir dist/hpc/lambdacube-compiler -prof -fprof-auto -rtsopts | ||
95 | else | ||
96 | GHC-Options: -O2 -fhpc -hpcdir dist/hpc/lambdacube-compiler | ||
diff --git a/prototypes/runTests.hs b/prototypes/runTests.hs deleted file mode 120000 index 74e37a7a..00000000 --- a/prototypes/runTests.hs +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../runTests.hs \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/Builtins.lc b/prototypes/tests/accept/Builtins.lc deleted file mode 100644 index 187a6e9e..00000000 --- a/prototypes/tests/accept/Builtins.lc +++ /dev/null | |||
@@ -1,568 +0,0 @@ | |||
1 | {-# LANGUAGE NoImplicitPrelude #-} | ||
2 | -- module Builtins where | ||
3 | |||
4 | builtins | ||
5 | cstr :: Type -> Type -> Type | ||
6 | -- reflCstr :: forall (a :: Type) -> cstr a a | ||
7 | T2 :: Type -> Type -> Type | ||
8 | T2C :: Unit -> Unit -> Unit | ||
9 | |||
10 | data Unit = TT | ||
11 | |||
12 | -- TODO: generate? | ||
13 | data Tuple0 = Tuple0 | ||
14 | data Tuple1 a = Tuple1 a | ||
15 | data Tuple2 a b = Tuple2 a b | ||
16 | data Tuple3 a b c = Tuple3 a b c | ||
17 | data Tuple4 a b c d = Tuple4 a b c d | ||
18 | data Tuple5 a b c d e = Tuple5 a b c d e | ||
19 | |||
20 | id x = x | ||
21 | |||
22 | data Bool = False | True | ||
23 | |||
24 | data Ordering = LT | EQ | GT | ||
25 | |||
26 | primIfThenElse :: Bool -> a -> a -> a | ||
27 | primIfThenElse True a b = a | ||
28 | primIfThenElse False a b = b | ||
29 | |||
30 | --------------------------------------- | ||
31 | |||
32 | data Nat = Zero | Succ Nat | ||
33 | |||
34 | builtintycons | ||
35 | Int :: Type | ||
36 | Word :: Type | ||
37 | Float :: Type | ||
38 | Char :: Type | ||
39 | String :: Type | ||
40 | |||
41 | {- | ||
42 | type family TFVec (n :: Nat) a -- may be a data family | ||
43 | type family VecScalar (n :: Nat) a | ||
44 | type family TFMat i j -- may be a data family | ||
45 | type family MatVecElem a | ||
46 | type family MatVecScalarElem a | ||
47 | type family FTRepr' a | ||
48 | type family ColorRepr a | ||
49 | type family TFFrameBuffer a | ||
50 | type family FragOps a | ||
51 | type family JoinTupleType t1 t2 | ||
52 | class AttributeTuple a | ||
53 | class ValidOutput a | ||
54 | class ValidFrameBuffer a | ||
55 | -} | ||
56 | builtins | ||
57 | TFVec :: Nat -> Type -> Type | ||
58 | VecScalar :: Nat -> Type -> Type | ||
59 | TFMat :: Type -> Type -> Type | ||
60 | MatVecElem :: Type -> Type | ||
61 | MatVecScalarElem :: Type -> Type | ||
62 | FTRepr' :: Type -> Type | ||
63 | ColorRepr :: Type -> Type | ||
64 | TFFrameBuffer :: Type -> Type | ||
65 | FragOps :: Type -> Type | ||
66 | JoinTupleType :: Type -> Type -> Type | ||
67 | |||
68 | AttributeTuple :: Type -> Type | ||
69 | ValidOutput :: Type -> Type | ||
70 | ValidFrameBuffer :: Type -> Type | ||
71 | |||
72 | data VecS (a :: Type) :: Nat -> Type where | ||
73 | V2 :: a -> a -> VecS a 2 | ||
74 | V3 :: a -> a -> a -> VecS a 3 | ||
75 | V4 :: a -> a -> a -> a -> VecS a 4 | ||
76 | |||
77 | builtins | ||
78 | Vec :: Nat -> Type -> Type | ||
79 | --Vec n t = VecS t n | ||
80 | |||
81 | |||
82 | data Mat :: Nat -> Nat -> Type -> Type where | ||
83 | M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float | ||
84 | M23F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 3 Float | ||
85 | M24F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 4 Float | ||
86 | M32F :: Vec 3 Float -> Vec 3 Float -> Mat 3 2 Float | ||
87 | M33F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 3 Float | ||
88 | M34F :: Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Vec 3 Float -> Mat 3 4 Float | ||
89 | M42F :: Vec 4 Float -> Vec 4 Float -> Mat 4 2 Float | ||
90 | M43F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 3 Float | ||
91 | M44F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 4 Float | ||
92 | |||
93 | |||
94 | builtins | ||
95 | CNum, Signed, Num, Component, Integral, NumComponent, Floating :: Type -> Type | ||
96 | |||
97 | fromInt :: Num a => Int -> a | ||
98 | compare :: Num a => a -> a -> Ordering | ||
99 | negate :: Num a => a -> a | ||
100 | |||
101 | vec2 :: Component a => a -> a -> Vec 2 a | ||
102 | vec3 :: Component a => a -> a -> a -> Vec 3 a | ||
103 | vec4 :: Component a => a -> a -> a -> a -> Vec 4 a | ||
104 | zeroComp :: Component a => a | ||
105 | oneComp :: Component a => a | ||
106 | |||
107 | --------------------------------------- swizzling | ||
108 | |||
109 | data Swizz = Sx | Sy | Sz | Sw | ||
110 | |||
111 | builtins | ||
112 | swizzvector :: forall n . forall m . Vec n a -> Vec m Swizz -> Vec m a | ||
113 | swizzscalar :: forall n . Vec n a -> Swizz -> a | ||
114 | |||
115 | {- | ||
116 | --------------------------------------- type classes | ||
117 | |||
118 | class CNum a | ||
119 | |||
120 | instance CNum Int | ||
121 | instance CNum Float | ||
122 | |||
123 | class Signed a | ||
124 | |||
125 | instance Signed Int | ||
126 | instance Signed Float | ||
127 | |||
128 | class Num a where | ||
129 | fromInt :: Int -> a | ||
130 | compare :: a -> a -> Ordering | ||
131 | negate :: a -> a | ||
132 | -} | ||
133 | builtins | ||
134 | primIntToWord :: Int -> Word | ||
135 | primIntToFloat :: Int -> Float | ||
136 | primCompareInt :: Int -> Int -> Ordering | ||
137 | primCompareWord :: Word -> Word -> Ordering | ||
138 | primCompareFloat :: Float -> Float -> Ordering | ||
139 | primNegateInt :: Int -> Int | ||
140 | primNegateWord :: Word -> Word | ||
141 | primNegateFloat :: Float -> Float | ||
142 | |||
143 | {- | ||
144 | instance Num Int where | ||
145 | fromInt = id | ||
146 | compare = primCompareInt | ||
147 | negate = primNegateInt | ||
148 | instance Num Word where | ||
149 | fromInt = primIntToWord | ||
150 | compare = primCompareWord | ||
151 | negate = primNegateWord | ||
152 | instance Num Float where | ||
153 | fromInt = primIntToFloat | ||
154 | compare = primCompareFloat | ||
155 | negate = primNegateFloat | ||
156 | |||
157 | class Component a where | ||
158 | vec2 :: a -> a -> Vec 2 a | ||
159 | vec3 :: a -> a -> a -> Vec 3 a | ||
160 | vec4 :: a -> a -> a -> a -> Vec 4 a | ||
161 | zeroComp :: a | ||
162 | oneComp :: a | ||
163 | -- PrimZero, PrimOne :: {- (Component a) => -- TODO -} a | ||
164 | |||
165 | |||
166 | instance Component Bool where | ||
167 | vec2 = V2 | ||
168 | vec3 = V3 | ||
169 | vec4 = V4 | ||
170 | zeroComp = False | ||
171 | oneComp = True | ||
172 | |||
173 | instance Component Int where | ||
174 | vec2 = V2 | ||
175 | vec3 = V3 | ||
176 | vec4 = V4 | ||
177 | zeroComp = 0 | ||
178 | oneComp = 1 | ||
179 | |||
180 | instance Component Word where | ||
181 | vec2 = V2 | ||
182 | vec3 = V3 | ||
183 | vec4 = V4 | ||
184 | zeroComp = 0 | ||
185 | oneComp = 1 | ||
186 | |||
187 | instance Component Float where | ||
188 | vec2 = V2 | ||
189 | vec3 = V3 | ||
190 | vec4 = V4 | ||
191 | zeroComp = 0 | ||
192 | oneComp = 1 | ||
193 | |||
194 | instance Component (Vec 2 Float) where | ||
195 | vec2 = V2 | ||
196 | vec3 = V3 | ||
197 | vec4 = V4 | ||
198 | zeroComp = V2 0.0 0.0 | ||
199 | oneComp = V2 1.0 1.0 | ||
200 | instance Component (Vec 3 Float) where | ||
201 | vec2 = V2 | ||
202 | vec3 = V3 | ||
203 | vec4 = V4 | ||
204 | zeroComp = V3 0.0 0.0 0.0 | ||
205 | oneComp = V3 1.0 1.0 1.0 | ||
206 | instance Component (Vec 4 Float) where | ||
207 | vec2 = V2 | ||
208 | vec3 = V3 | ||
209 | vec4 = V4 | ||
210 | zeroComp = V4 0.0 0.0 0.0 0.0 | ||
211 | oneComp = V4 1.0 1.0 1.0 1.0 | ||
212 | |||
213 | --instance Component (Vec 2 Bool) where | ||
214 | --instance Component (Vec 3 Bool) where | ||
215 | |||
216 | instance Component (Vec 4 Bool) where | ||
217 | vec2 = V2 | ||
218 | vec3 = V3 | ||
219 | vec4 = V4 | ||
220 | zeroComp = V4 False False False False | ||
221 | oneComp = V4 True True True True | ||
222 | |||
223 | class Integral a | ||
224 | |||
225 | instance Integral Int | ||
226 | instance Integral Word | ||
227 | |||
228 | class NumComponent a | ||
229 | |||
230 | instance NumComponent Int | ||
231 | instance NumComponent Word | ||
232 | instance NumComponent Float | ||
233 | instance NumComponent (Vec 2 Float) | ||
234 | instance NumComponent (Vec 3 Float) | ||
235 | instance NumComponent (Vec 4 Float) | ||
236 | |||
237 | class Floating a | ||
238 | |||
239 | instance Floating Float | ||
240 | instance Floating (Vec 2 Float) | ||
241 | instance Floating (Vec 3 Float) | ||
242 | instance Floating (Vec 4 Float) | ||
243 | instance Floating (Mat 2 2 Float) | ||
244 | instance Floating (Mat 2 3 Float) | ||
245 | instance Floating (Mat 2 4 Float) | ||
246 | instance Floating (Mat 3 2 Float) | ||
247 | instance Floating (Mat 3 3 Float) | ||
248 | instance Floating (Mat 3 4 Float) | ||
249 | instance Floating (Mat 4 2 Float) | ||
250 | instance Floating (Mat 4 3 Float) | ||
251 | instance Floating (Mat 4 4 Float) | ||
252 | -} | ||
253 | |||
254 | data BlendingFactor | ||
255 | = Zero' --- FIXME: modified | ||
256 | | One | ||
257 | | SrcColor | ||
258 | | OneMinusSrcColor | ||
259 | | DstColor | ||
260 | | OneMinusDstColor | ||
261 | | SrcAlpha | ||
262 | | OneMinusSrcAlpha | ||
263 | | DstAlpha | ||
264 | | OneMinusDstAlpha | ||
265 | | ConstantColor | ||
266 | | OneMinusConstantColor | ||
267 | | ConstantAlpha | ||
268 | | OneMinusConstantAlpha | ||
269 | | SrcAlphaSaturate | ||
270 | |||
271 | data BlendEquation | ||
272 | = FuncAdd | ||
273 | | FuncSubtract | ||
274 | | FuncReverseSubtract | ||
275 | | Min | ||
276 | | Max | ||
277 | |||
278 | data LogicOperation | ||
279 | = Clear | ||
280 | | And | ||
281 | | AndReverse | ||
282 | | Copy | ||
283 | | AndInverted | ||
284 | | Noop | ||
285 | | Xor | ||
286 | | Or | ||
287 | | Nor | ||
288 | | Equiv | ||
289 | | Invert | ||
290 | | OrReverse | ||
291 | | CopyInverted | ||
292 | | OrInverted | ||
293 | | Nand | ||
294 | | Set | ||
295 | |||
296 | data StencilOperation | ||
297 | = OpZero | ||
298 | | OpKeep | ||
299 | | OpReplace | ||
300 | | OpIncr | ||
301 | | OpIncrWrap | ||
302 | | OpDecr | ||
303 | | OpDecrWrap | ||
304 | | OpInvert | ||
305 | |||
306 | data ComparisonFunction | ||
307 | = Never | ||
308 | | Less | ||
309 | | Equal | ||
310 | | Lequal | ||
311 | | Greater | ||
312 | | Notequal | ||
313 | | Gequal | ||
314 | | Always | ||
315 | |||
316 | data ProvokingVertex | ||
317 | = LastVertex | ||
318 | | FirstVertex | ||
319 | |||
320 | data FrontFace | ||
321 | = CW | ||
322 | | CCW | ||
323 | |||
324 | data CullMode | ||
325 | = CullFront FrontFace | ||
326 | | CullBack FrontFace | ||
327 | | CullNone | ||
328 | |||
329 | data PointSize | ||
330 | = PointSize Float | ||
331 | | ProgramPointSize | ||
332 | |||
333 | data PolygonMode | ||
334 | = PolygonFill | ||
335 | | PolygonPoint PointSize | ||
336 | | PolygonLine Float | ||
337 | |||
338 | data PolygonOffset | ||
339 | = NoOffset | ||
340 | | Offset Float Float | ||
341 | |||
342 | data PointSpriteCoordOrigin | ||
343 | = LowerLeft | ||
344 | | UpperLeft | ||
345 | |||
346 | |||
347 | data Depth a where | ||
348 | data Stencil a where | ||
349 | data Color a where | ||
350 | |||
351 | data PrimitiveType | ||
352 | = Triangle | ||
353 | | Line | ||
354 | | Point | ||
355 | | TriangleAdjacency | ||
356 | | LineAdjacency | ||
357 | |||
358 | builtincons | ||
359 | PrimTexture :: () -> Vec 2 Float -> Vec 4 Float | ||
360 | |||
361 | builtincons | ||
362 | Uniform :: String -> t | ||
363 | Attribute :: String -> t | ||
364 | |||
365 | data FragmentOut a where | ||
366 | FragmentOut :: (a ~ ColorRepr t) => t -> FragmentOut a | ||
367 | FragmentOutDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => Float -> t | ||
368 | -> FragmentOut a | ||
369 | FragmentOutRastDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => t | ||
370 | -> FragmentOut a | ||
371 | |||
372 | data VertexOut a where | ||
373 | VertexOut :: (a ~ FTRepr' x) => Vec 4 Float -> Float -> (){-TODO-} -> x -> VertexOut a | ||
374 | |||
375 | data RasterContext :: PrimitiveType -> Type where | ||
376 | TriangleCtx :: CullMode -> PolygonMode -> PolygonOffset -> ProvokingVertex -> RasterContext Triangle | ||
377 | PointCtx :: PointSize -> Float -> PointSpriteCoordOrigin -> RasterContext Point | ||
378 | LineCtx :: Float -> ProvokingVertex -> RasterContext Line | ||
379 | |||
380 | data FetchPrimitive :: PrimitiveType -> Type where | ||
381 | Points :: FetchPrimitive Point | ||
382 | Lines :: FetchPrimitive Line | ||
383 | Triangles :: FetchPrimitive Triangle | ||
384 | LinesAdjacency :: FetchPrimitive LineAdjacency | ||
385 | TrianglesAdjacency :: FetchPrimitive TriangleAdjacency | ||
386 | |||
387 | data AccumulationContext a where | ||
388 | AccumulationContext :: (a ~ FragOps t) => t -> AccumulationContext a | ||
389 | |||
390 | data Image (a :: Nat) :: Type -> Type where | ||
391 | ColorImage :: (Num t, color ~ VecScalar d t) | ||
392 | => color -> Image a (Color color) | ||
393 | DepthImage :: Float -> Image a (Depth Float) | ||
394 | StencilImage :: Int -> Image a (Stencil Int) | ||
395 | |||
396 | data Interpolated t where | ||
397 | Smooth, NoPerspective | ||
398 | :: (Floating t) => t -> Interpolated t | ||
399 | Flat :: t -> Interpolated t | ||
400 | |||
401 | data Blending :: Type -> Type where | ||
402 | NoBlending :: Blending t | ||
403 | BlendLogicOp :: (Integral t) => LogicOperation -> Blending t | ||
404 | Blend :: (BlendEquation, BlendEquation) | ||
405 | -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) | ||
406 | -> Vec 4 Float -> Blending Float | ||
407 | |||
408 | {- TODO: more precise kinds | ||
409 | FragmentOperation :: Semantic -> * | ||
410 | FragmentOut :: Semantic -> * | ||
411 | VertexOut :: ??? | ||
412 | -} | ||
413 | |||
414 | data FragmentOperation :: Type -> Type where | ||
415 | ColorOp :: (mask ~ VecScalar d Bool, color ~ VecScalar d c, Num c) => Blending c -> mask | ||
416 | -> FragmentOperation (Color color) | ||
417 | DepthOp :: ComparisonFunction -> Bool -> FragmentOperation (Depth Float) | ||
418 | StencilOp :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation (Stencil Int32) | ||
419 | |||
420 | data FragmentFilter t where | ||
421 | PassAll :: FragmentFilter t | ||
422 | Filter :: (t -> Bool) -> FragmentFilter t | ||
423 | |||
424 | data VertexStream (a :: PrimitiveType) t where | ||
425 | Fetch :: (AttributeTuple t) => String -> FetchPrimitive a -> t -> VertexStream a t | ||
426 | FetchArrays :: (AttributeTuple t, t ~ FTRepr' t') => FetchPrimitive a -> t' -> VertexStream a t | ||
427 | |||
428 | data PrimitiveStream (p :: PrimitiveType) :: Nat -> Type -> Type where | ||
429 | Transform :: (a -> VertexOut b) -> VertexStream p a -> PrimitiveStream p 1 b | ||
430 | |||
431 | -- Render Operations | ||
432 | data FragmentStream (n :: Nat) a where | ||
433 | Rasterize :: RasterContext x -> PrimitiveStream x n a -> FragmentStream n a | ||
434 | |||
435 | data FrameBuffer (n :: Nat) b where | ||
436 | Accumulate :: (ValidOutput b) => | ||
437 | AccumulationContext b | ||
438 | -> FragmentFilter a | ||
439 | -> (a -> FragmentOut b) | ||
440 | -> FragmentStream n a | ||
441 | -> FrameBuffer n b | ||
442 | -> FrameBuffer n b | ||
443 | |||
444 | FrameBuffer :: (ValidFrameBuffer b, FrameBuffer n b ~ TFFrameBuffer a) | ||
445 | => a -> FrameBuffer n b | ||
446 | |||
447 | |||
448 | data Output where | ||
449 | ScreenOut :: FrameBuffer a b -> Output | ||
450 | |||
451 | builtins | ||
452 | -- * Primitive Functions * | ||
453 | -- Arithmetic Functions (componentwise) | ||
454 | |||
455 | PrimAdd, PrimSub, PrimMul :: (t ~ MatVecElem a, Num t) => a -> a -> a | ||
456 | PrimAddS, PrimSubS, PrimMulS :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a | ||
457 | PrimDiv, PrimMod :: (Num t, a ~ VecScalar d t) => a -> a -> a | ||
458 | PrimDivS, PrimModS :: (Num t, a ~ VecScalar d t) => a -> t -> a | ||
459 | PrimNeg :: (t ~ MatVecScalarElem a, Signed t) => a -> a | ||
460 | -- Bit-wise Functions | ||
461 | PrimBAnd, PrimBOr, PrimBXor :: (Integral t, a ~ VecScalar d t) => a -> a -> a | ||
462 | PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a | ||
463 | PrimBNot :: (Integral t, a ~ VecScalar d t) => a -> a | ||
464 | PrimBShiftL, PrimBShiftR :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a | ||
465 | PrimBShiftLS, PrimBShiftRS :: (Integral t, a ~ VecScalar d t) => a -> Word -> a | ||
466 | -- Logic Functions | ||
467 | PrimAnd, PrimOr, PrimXor :: Bool -> Bool -> Bool | ||
468 | PrimNot :: (a ~ VecScalar d Bool) => a -> a | ||
469 | PrimAny, PrimAll :: (a ~ VecScalar d Bool) => a -> Bool | ||
470 | |||
471 | -- Angle, Trigonometry and Exponential Functions | ||
472 | PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt | ||
473 | :: (a ~ VecScalar d Float) => a -> a | ||
474 | PrimPow, PrimATan2 :: (a ~ VecScalar d Float) => a -> a -> a | ||
475 | -- Common Functions | ||
476 | PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract | ||
477 | :: (a ~ VecScalar d Float) => a -> a | ||
478 | PrimMin, PrimMax :: (Num t, a ~ VecScalar d t) => a -> a -> a | ||
479 | PrimMinS, PrimMaxS :: (Num t, a ~ VecScalar d t) => a -> t -> a | ||
480 | PrimIsNan, PrimIsInf :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b | ||
481 | PrimAbs, PrimSign :: (Signed t, a ~ VecScalar d t) => a -> a | ||
482 | PrimModF :: (a ~ VecScalar d Float) => a -> (a, a) | ||
483 | PrimClamp :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a | ||
484 | PrimClampS :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a | ||
485 | PrimMix :: (a ~ VecScalar d Float) => a -> a -> a -> a | ||
486 | PrimMixS :: (a ~ VecScalar d Float) => a -> a -> Float -> a | ||
487 | PrimMixB :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> a -> b -> a | ||
488 | PrimStep :: (a ~ TFVec d Float) => a -> a -> a | ||
489 | PrimStepS :: (a ~ VecScalar d Float) => Float -> a -> a | ||
490 | PrimSmoothStep :: (a ~ TFVec d Float) => a -> a -> a -> a | ||
491 | PrimSmoothStepS :: (a ~ VecScalar d Float) => Float -> Float -> a -> a | ||
492 | |||
493 | -- Integer/Floatonversion Functions | ||
494 | PrimFloatBitsToInt :: (fv ~ VecScalar d Float, iv ~ VecScalar d Int) => fv -> iv | ||
495 | PrimFloatBitsToUInt :: (fv ~ VecScalar d Float, uv ~ VecScalar d Word) => fv -> uv | ||
496 | PrimIntBitsToFloat :: (fv ~ VecScalar d Float, iv ~ VecScalar d Int) => iv -> fv | ||
497 | PrimUIntBitsToFloat :: (fv ~ VecScalar d Float, uv ~ VecScalar d Word) => uv -> fv | ||
498 | -- Geometric Functions | ||
499 | PrimLength :: (a ~ VecScalar d Float) => a -> Float | ||
500 | PrimDistance, PrimDot | ||
501 | :: (a ~ VecScalar d Float) => a -> a -> Float | ||
502 | PrimCross :: (a ~ VecScalar 3 Float) => a -> a -> a | ||
503 | PrimNormalize :: (a ~ VecScalar d Float) => a -> a | ||
504 | PrimFaceForward, PrimRefract | ||
505 | :: (a ~ VecScalar d Float) => a -> a -> a -> a | ||
506 | PrimReflect :: (a ~ VecScalar d Float) => a -> a -> a | ||
507 | -- Matrix Functions | ||
508 | PrimTranspose :: (a ~ TFMat h w, b ~ TFMat w h) => a -> b | ||
509 | PrimDeterminant :: (m ~ TFMat s s) => m -> Float | ||
510 | PrimInverse :: (m ~ TFMat s s) => m -> m | ||
511 | PrimOuterProduct :: (m ~ TFMat h w) => w -> h -> m | ||
512 | PrimMulMatVec :: (m ~ TFMat h w) => m -> w -> h | ||
513 | PrimMulVecMat :: (m ~ TFMat h w) => h -> m -> w | ||
514 | PrimMulMatMat :: (a ~ TFMat i j, b ~ TFMat j k, c ~ TFMat i k) => a -> b -> c | ||
515 | -- Vector and Scalar Relational Functions | ||
516 | PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV | ||
517 | :: (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b | ||
518 | PrimEqual, PrimNotEqual | ||
519 | :: (t ~ MatVecScalarElem a) => a -> a -> Bool | ||
520 | -- Fragment Processing Functions | ||
521 | PrimDFdx, PrimDFdy, PrimFWidth | ||
522 | :: (a ~ VecScalar d Float) => a -> a | ||
523 | -- Noise Functions | ||
524 | PrimNoise1 :: (a ~ VecScalar d Float) => a -> Float | ||
525 | PrimNoise2 :: (a ~ VecScalar d Float, b ~ VecScalar 2 Float) => a -> b | ||
526 | PrimNoise3 :: (a ~ VecScalar d Float, b ~ VecScalar 3 Float) => a -> b | ||
527 | PrimNoise4 :: (a ~ VecScalar d Float, b ~ VecScalar 4 Float) => a -> b | ||
528 | |||
529 | {- | ||
530 | -- Vec/Mat (de)construction | ||
531 | PrimTupToV2 :: Component a => PrimFun stage ((a,a) -> V2 a) | ||
532 | PrimTupToV3 :: Component a => PrimFun stage ((a,a,a) -> V3 a) | ||
533 | PrimTupToV4 :: Component a => PrimFun stage ((a,a,a,a) -> V4 a) | ||
534 | PrimV2ToTup :: Component a => PrimFun stage (V2 a -> (a,a)) | ||
535 | PrimV3ToTup :: Component a => PrimFun stage (V3 a -> (a,a,a)) | ||
536 | PrimV4ToTup :: Component a => PrimFun stage (V4 a -> (a,a,a,a)) | ||
537 | -} | ||
538 | |||
539 | -------------------- | ||
540 | -- * Texture support | ||
541 | -- FIXME: currently only Float RGBA 2D texture is supported | ||
542 | |||
543 | builtincons | ||
544 | PrjImage :: FrameBuffer 1 a -> Image 1 a | ||
545 | PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float)) | ||
546 | |||
547 | data Texture where | ||
548 | Texture2DSlot :: String -- texture slot name | ||
549 | -> Texture | ||
550 | |||
551 | Texture2D :: Vec 2 Int -- FIXME: use Word here | ||
552 | -> Image 1 (Color (Vec 4 Float)) | ||
553 | -> Texture | ||
554 | |||
555 | data Filter | ||
556 | = PointFilter | ||
557 | | LinearFilter | ||
558 | |||
559 | data EdgeMode | ||
560 | = Repeat | ||
561 | | MirroredRepeat | ||
562 | | ClampToEdge | ||
563 | |||
564 | data Sampler = Sampler Filter EdgeMode Texture | ||
565 | |||
566 | builtincons | ||
567 | texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float | ||
568 | |||
diff --git a/prototypes/tests/accept/Graphics.lc b/prototypes/tests/accept/Graphics.lc deleted file mode 120000 index 974d8372..00000000 --- a/prototypes/tests/accept/Graphics.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/Graphics.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/Material.lc b/prototypes/tests/accept/Material.lc deleted file mode 120000 index d8ac6673..00000000 --- a/prototypes/tests/accept/Material.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/Material.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/NewStyle.lc b/prototypes/tests/accept/NewStyle.lc deleted file mode 120000 index 68032c3f..00000000 --- a/prototypes/tests/accept/NewStyle.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/NewStyle.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/Prelude.lc b/prototypes/tests/accept/Prelude.lc deleted file mode 100644 index 35d27f0a..00000000 --- a/prototypes/tests/accept/Prelude.lc +++ /dev/null | |||
@@ -1,311 +0,0 @@ | |||
1 | {-# LANGUAGE NoImplicitPrelude #-} | ||
2 | module Prelude | ||
3 | ( module Prelude | ||
4 | , module Builtins | ||
5 | ) where | ||
6 | |||
7 | import Builtins | ||
8 | |||
9 | infixr 9 . | ||
10 | infixl 7 `PrimMulMatVec`, `PrimDot` | ||
11 | infixr 3 *** | ||
12 | infixr 5 : | ||
13 | infixr 0 $ | ||
14 | --infixl 0 & | ||
15 | |||
16 | const x y = x | ||
17 | |||
18 | otherwise = True | ||
19 | |||
20 | --undefined = undefined | ||
21 | |||
22 | builtins | ||
23 | undefined :: forall (a :: Type) . a | ||
24 | |||
25 | x & f = f x | ||
26 | |||
27 | ($) = \f x -> f x | ||
28 | (.) = \f g x -> f (g x) | ||
29 | |||
30 | uncurry f (x, y) = f x y | ||
31 | |||
32 | (***) f g (x, y) = (f x, g y) | ||
33 | |||
34 | data List a = Nil | Cons a (List a) | ||
35 | |||
36 | pi = 3.14 | ||
37 | |||
38 | zip :: [a] -> [b] -> [(a,b)] | ||
39 | zip [] xs = [] | ||
40 | zip xs [] = [] | ||
41 | zip (a: as) (b: bs) = (a,b): zip as bs | ||
42 | |||
43 | unzip :: [(a,b)] -> ([a],[b]) | ||
44 | unzip [] = ([],[]) | ||
45 | unzip ((a,b):xs) = (a:as,b:bs) | ||
46 | where (as,bs) = unzip xs | ||
47 | |||
48 | filter pred [] = [] | ||
49 | filter pred (x:xs) = case pred x of | ||
50 | True -> (x : filter pred xs) | ||
51 | False -> (filter pred xs) | ||
52 | |||
53 | tail :: [a] -> [a] | ||
54 | tail (_: xs) = xs | ||
55 | |||
56 | pairs :: [a] -> [(a, a)] | ||
57 | pairs v = zip v (tail v) | ||
58 | |||
59 | foldl' f e [] = e | ||
60 | foldl' f e (x: xs) = foldl' f (f e x) xs | ||
61 | |||
62 | singleton a = [a] | ||
63 | |||
64 | append [] ys = ys | ||
65 | append (x:xs) ys = x : append xs ys | ||
66 | |||
67 | concat = foldl' append [] | ||
68 | |||
69 | map _ [] = [] | ||
70 | map f (x:xs) = f x : map f xs | ||
71 | |||
72 | concatMap :: (a -> [b]) -> [a] -> [b] | ||
73 | concatMap f x = concat (map f x) | ||
74 | |||
75 | split [] = ([], []) | ||
76 | split (x: xs) = (x: bs, as) where (as, bs) = split xs | ||
77 | |||
78 | mergeBy f (x:xs) (y:ys) = case f x y of | ||
79 | LT -> x: mergeBy f xs (y:ys) | ||
80 | _ -> y: mergeBy f (x:xs) ys | ||
81 | mergeBy f [] xs = xs | ||
82 | mergeBy f xs [] = xs | ||
83 | |||
84 | sortBy f [] = [] | ||
85 | sortBy f [x] = [x] | ||
86 | sortBy f xs = uncurry (mergeBy f) ((sortBy f *** sortBy f) (split xs)) | ||
87 | |||
88 | data Maybe a | ||
89 | = Nothing | ||
90 | | Just a | ||
91 | -- deriving (Eq, Ord, Show) | ||
92 | |||
93 | |||
94 | snd (Tuple2 a b) = b | ||
95 | |||
96 | -- Row polymorphism | ||
97 | builtins | ||
98 | Split :: Type -> Type -> Type -> Type {- TODO - LATER: Constraint -} | ||
99 | |||
100 | tuptype :: List Type -> Type | ||
101 | tuptype [] = 'Tuple0 | ||
102 | tuptype (x:xs) = 'Tuple2 x (tuptype xs) | ||
103 | |||
104 | data RecordC (xs :: List (Tuple2 String Type)) | ||
105 | = RecordCons (tuptype (map snd xs)) | ||
106 | |||
107 | builtins | ||
108 | record :: List (Tuple2 String Type) -> Type | ||
109 | --record xs = RecordCons ({- TODO: sortBy fst-} xs) | ||
110 | |||
111 | builtins | ||
112 | project :: forall (xs :: List (Tuple2 String Type)) . forall (s :: String) -> Split (RecordC xs) (RecordC ('Cons ('Tuple2 s a) 'Nil)) b => RecordC xs -> a | ||
113 | |||
114 | |||
115 | --------------------------------------- HTML colors | ||
116 | |||
117 | rgb r g b = V4 r g b 1.0 | ||
118 | |||
119 | black = rgb 0.0 0.0 0.0 | ||
120 | gray = rgb 0.5 0.5 0.5 | ||
121 | silver = rgb 0.75 0.75 0.75 | ||
122 | white = rgb 1.0 1.0 1.0 | ||
123 | maroon = rgb 0.5 0.0 0.0 | ||
124 | red = rgb 1.0 0.0 0.0 | ||
125 | olive = rgb 0.5 0.5 0.0 | ||
126 | yellow = rgb 1.0 1.0 0.0 | ||
127 | green = rgb 0.0 0.5 0.0 | ||
128 | lime = rgb 0.0 1.0 0.0 | ||
129 | teal = rgb 0.0 0.5 0.5 | ||
130 | aqua = rgb 0.0 1.0 1.0 | ||
131 | navy = rgb 0.0 0.0 0.5 | ||
132 | blue = rgb 0.0 0.0 1.0 | ||
133 | purple = rgb 0.5 0.0 0.5 | ||
134 | fuchsia = rgb 1.0 0.0 1.0 | ||
135 | |||
136 | colorImage1 = ColorImage @1 | ||
137 | colorImage2 = ColorImage @2 | ||
138 | |||
139 | depthImage1 = DepthImage @1 | ||
140 | |||
141 | v3FToV4F :: Vec 3 Float -> Vec 4 Float | ||
142 | v3FToV4F v = V4 0.0 0.0 0.0 1.0 --- todo! -- V4 v%x v%y v%z 1 | ||
143 | |||
144 | ------------ | ||
145 | -- * WebGL 1 | ||
146 | ------------ | ||
147 | |||
148 | -- angle and trigonometric | ||
149 | radians = PrimRadians | ||
150 | degrees = PrimDegrees | ||
151 | sin = PrimSin | ||
152 | cos = PrimCos | ||
153 | tan = PrimTan | ||
154 | asin = PrimASin | ||
155 | acos = PrimACos | ||
156 | atan = PrimATan | ||
157 | atan2 = PrimATan2 | ||
158 | |||
159 | -- exponential functions | ||
160 | pow = PrimPow | ||
161 | exp = PrimExp | ||
162 | log = PrimLog | ||
163 | exp2 = PrimExp2 | ||
164 | log2 = PrimLog2 | ||
165 | sqrt = PrimSqrt | ||
166 | inversesqrt = PrimInvSqrt | ||
167 | |||
168 | -- common functions | ||
169 | abs = PrimAbs | ||
170 | sign = PrimSign | ||
171 | floor = PrimFloor | ||
172 | ceil = PrimCeil | ||
173 | fract = PrimFract | ||
174 | mod = PrimMod | ||
175 | min = PrimMin | ||
176 | max = PrimMax | ||
177 | clamp = PrimClamp | ||
178 | clampS = PrimClampS | ||
179 | mix = PrimMix | ||
180 | step = PrimStep | ||
181 | smoothstep = PrimSmoothStep | ||
182 | |||
183 | -- geometric functions | ||
184 | length = PrimLength | ||
185 | distance = PrimDistance | ||
186 | dot = PrimDot | ||
187 | cross = PrimCross | ||
188 | normalize = PrimNormalize | ||
189 | faceforward = PrimFaceForward | ||
190 | reflect = PrimReflect | ||
191 | refract = PrimRefract | ||
192 | |||
193 | -- operators | ||
194 | infixl 7 *, /, % | ||
195 | infixl 6 +, - | ||
196 | infix 4 ==, /=, <, <=, >=, > | ||
197 | |||
198 | infixr 3 && | ||
199 | infixr 2 || | ||
200 | |||
201 | infix 7 `dot` -- dot | ||
202 | infix 7 `cross` -- cross | ||
203 | |||
204 | infixr 7 *. -- mulmv | ||
205 | infixl 7 .* -- mulvm | ||
206 | infixl 7 .*. -- mulmm | ||
207 | |||
208 | -- arithemtic | ||
209 | a + b = PrimAdd a b | ||
210 | a - b = PrimSub a b | ||
211 | a * b = PrimMul a b | ||
212 | a / b = PrimDiv a b | ||
213 | a % b = PrimMod a b | ||
214 | |||
215 | neg a = PrimNeg a | ||
216 | |||
217 | -- comparison | ||
218 | a == b = PrimEqual a b | ||
219 | a /= b = PrimNotEqual a b | ||
220 | a < b = PrimLessThan a b | ||
221 | a <= b = PrimLessThanEqual a b | ||
222 | a >= b = PrimGreaterThanEqual a b | ||
223 | a > b = PrimGreaterThan a b | ||
224 | |||
225 | -- logical | ||
226 | a && b = PrimAnd a b | ||
227 | a || b = PrimOr a b | ||
228 | not a = PrimNot a | ||
229 | any a = PrimAny a | ||
230 | all a = PrimAll a | ||
231 | |||
232 | -- matrix functions | ||
233 | a .*. b = PrimMulMatMat a b | ||
234 | a *. b = PrimMulMatVec a b | ||
235 | a .* b = PrimMulVecMat a b | ||
236 | |||
237 | dFdx = PrimDFdx | ||
238 | dFdy = PrimDFdy | ||
239 | |||
240 | -- extra | ||
241 | round = PrimRound | ||
242 | |||
243 | |||
244 | -- temp hack for vector <---> scalar operators | ||
245 | infixl 7 *!, /!, %! | ||
246 | infixl 6 +!, -! | ||
247 | |||
248 | -- arithemtic | ||
249 | a +! b = PrimAddS a b | ||
250 | a -! b = PrimSubS a b | ||
251 | a *! b = PrimMulS a b | ||
252 | a /! b = PrimDivS a b | ||
253 | a %! b = PrimModS a b | ||
254 | |||
255 | ------------------ | ||
256 | -- common matrices | ||
257 | ------------------ | ||
258 | {- | ||
259 | -- | Perspective transformation matrix in row major order. | ||
260 | perspective :: Float -- ^ Near plane clipping distance (always positive). | ||
261 | -> Float -- ^ Far plane clipping distance (always positive). | ||
262 | -> Float -- ^ Field of view of the y axis, in radians. | ||
263 | -> Float -- ^ Aspect ratio, i.e. screen's width\/height. | ||
264 | -> Mat 4 4 Float | ||
265 | perspective n f fovy aspect = --transpose $ | ||
266 | M44F (V4F (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0) | ||
267 | (V4F 0 (2*n/(t-b)) ((t+b)/(t-b)) 0) | ||
268 | (V4F 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n))) | ||
269 | (V4F 0 0 (-1) 0) | ||
270 | where | ||
271 | t = n*tan(fovy/2) | ||
272 | b = -t | ||
273 | r = aspect*t | ||
274 | l = -r | ||
275 | -} | ||
276 | rotMatrixZ a = M44F (V4 c s 0 0) (V4 (-s) c 0 0) (V4 0 0 1 0) (V4 0 0 0 1) | ||
277 | where | ||
278 | c = cos a | ||
279 | s = sin a | ||
280 | |||
281 | rotMatrixY a = M44F (V4 c 0 (-s) 0) (V4 0 1 0 0) (V4 s 0 c 0) (V4 0 0 0 1) | ||
282 | where | ||
283 | c = cos a | ||
284 | s = sin a | ||
285 | |||
286 | rotMatrixX a = M44F (V4 1 0 0 0) (V4 0 c s 0) (V4 0 (-s) c 0) (V4 0 0 0 1) | ||
287 | where | ||
288 | c = cos a | ||
289 | s = sin a | ||
290 | |||
291 | rotationEuler a b c = rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c | ||
292 | |||
293 | {- | ||
294 | -- | Camera transformation matrix. | ||
295 | lookat :: Vec 3 Float -- ^ Camera position. | ||
296 | -> Vec 3 Float -- ^ Target position. | ||
297 | -> Vec 3 Float -- ^ Upward direction. | ||
298 | -> M44F | ||
299 | lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r) | ||
300 | where | ||
301 | w = normalize $ pos - target | ||
302 | u = normalize $ up `cross` w | ||
303 | v = w `cross` u | ||
304 | r = transpose $ Mat3 u v w | ||
305 | -} | ||
306 | |||
307 | scale t v = v * V4 t t t 1.0 | ||
308 | |||
309 | fromTo :: Float -> Float -> [Float] | ||
310 | fromTo a b = if a > b then [] else a:fromTo (a +! 1.0) b | ||
311 | |||
diff --git a/prototypes/tests/accept/PrimReduce.lc b/prototypes/tests/accept/PrimReduce.lc deleted file mode 120000 index 587d6508..00000000 --- a/prototypes/tests/accept/PrimReduce.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/PrimReduce.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/SampleMaterial.lc b/prototypes/tests/accept/SampleMaterial.lc deleted file mode 120000 index b8627b81..00000000 --- a/prototypes/tests/accept/SampleMaterial.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/SampleMaterial.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/ambig.lc b/prototypes/tests/accept/ambig.lc deleted file mode 120000 index 9259c4a8..00000000 --- a/prototypes/tests/accept/ambig.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/ambig.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/concatmap01.lc b/prototypes/tests/accept/concatmap01.lc deleted file mode 120000 index 43cee1d5..00000000 --- a/prototypes/tests/accept/concatmap01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/concatmap01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/dotdot01.lc b/prototypes/tests/accept/dotdot01.lc deleted file mode 120000 index 8274c557..00000000 --- a/prototypes/tests/accept/dotdot01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/dotdot01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/dotdot02.lc b/prototypes/tests/accept/dotdot02.lc deleted file mode 120000 index 78248be7..00000000 --- a/prototypes/tests/accept/dotdot02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/dotdot02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/example06.lc b/prototypes/tests/accept/example06.lc deleted file mode 120000 index 9a1cd6f1..00000000 --- a/prototypes/tests/accept/example06.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/example06.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/example07.lc b/prototypes/tests/accept/example07.lc deleted file mode 120000 index 70995cd0..00000000 --- a/prototypes/tests/accept/example07.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/example07.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/example08.lc b/prototypes/tests/accept/example08.lc deleted file mode 120000 index 206a7ce5..00000000 --- a/prototypes/tests/accept/example08.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/example08.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fetcharrays01.lc b/prototypes/tests/accept/fetcharrays01.lc deleted file mode 120000 index 190d5855..00000000 --- a/prototypes/tests/accept/fetcharrays01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fetcharrays01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fragment01.lc b/prototypes/tests/accept/fragment01.lc deleted file mode 120000 index 9a7d18cb..00000000 --- a/prototypes/tests/accept/fragment01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fragment01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fragment03swizzling.lc b/prototypes/tests/accept/fragment03swizzling.lc deleted file mode 120000 index f9b6c97e..00000000 --- a/prototypes/tests/accept/fragment03swizzling.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fragment03swizzling.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fragment04ifthenelse.lc b/prototypes/tests/accept/fragment04ifthenelse.lc deleted file mode 120000 index 15510f2c..00000000 --- a/prototypes/tests/accept/fragment04ifthenelse.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fragment04ifthenelse.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fragment07let.lc b/prototypes/tests/accept/fragment07let.lc deleted file mode 120000 index 42f8d268..00000000 --- a/prototypes/tests/accept/fragment07let.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fragment07let.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/framebuffer01.lc b/prototypes/tests/accept/framebuffer01.lc deleted file mode 120000 index f6f5b060..00000000 --- a/prototypes/tests/accept/framebuffer01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/framebuffer01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/framebuffer02.lc b/prototypes/tests/accept/framebuffer02.lc deleted file mode 120000 index 8a5e36e8..00000000 --- a/prototypes/tests/accept/framebuffer02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/framebuffer02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/framebuffer03.lc b/prototypes/tests/accept/framebuffer03.lc deleted file mode 120000 index ab6ddf42..00000000 --- a/prototypes/tests/accept/framebuffer03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/framebuffer03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/framebuffer04.lc b/prototypes/tests/accept/framebuffer04.lc deleted file mode 120000 index ddd9144d..00000000 --- a/prototypes/tests/accept/framebuffer04.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/framebuffer04.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/framebuffer05.lc b/prototypes/tests/accept/framebuffer05.lc deleted file mode 120000 index 99d73bbd..00000000 --- a/prototypes/tests/accept/framebuffer05.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/framebuffer05.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/fromto.lc b/prototypes/tests/accept/fromto.lc deleted file mode 120000 index 3656552c..00000000 --- a/prototypes/tests/accept/fromto.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/fromto.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx00.lc b/prototypes/tests/accept/gfx00.lc deleted file mode 120000 index ac68f6dc..00000000 --- a/prototypes/tests/accept/gfx00.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx00.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx01.lc b/prototypes/tests/accept/gfx01.lc deleted file mode 120000 index fdcd64c2..00000000 --- a/prototypes/tests/accept/gfx01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx02.lc b/prototypes/tests/accept/gfx02.lc deleted file mode 120000 index 7ac40c46..00000000 --- a/prototypes/tests/accept/gfx02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx03.lc b/prototypes/tests/accept/gfx03.lc deleted file mode 120000 index 01d05167..00000000 --- a/prototypes/tests/accept/gfx03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx04.lc b/prototypes/tests/accept/gfx04.lc deleted file mode 120000 index 8ab3d531..00000000 --- a/prototypes/tests/accept/gfx04.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx04.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/gfx05.lc b/prototypes/tests/accept/gfx05.lc deleted file mode 120000 index 8ff2c366..00000000 --- a/prototypes/tests/accept/gfx05.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/gfx05.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/heartbeat01.lc b/prototypes/tests/accept/heartbeat01.lc deleted file mode 120000 index 4915e9e2..00000000 --- a/prototypes/tests/accept/heartbeat01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/heartbeat01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/id.lc b/prototypes/tests/accept/id.lc deleted file mode 120000 index 033be71e..00000000 --- a/prototypes/tests/accept/id.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/id.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/ifThenElse01.lc b/prototypes/tests/accept/ifThenElse01.lc deleted file mode 120000 index 910b04fa..00000000 --- a/prototypes/tests/accept/ifThenElse01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/ifThenElse01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/instantiate.lc b/prototypes/tests/accept/instantiate.lc deleted file mode 120000 index 4bba908b..00000000 --- a/prototypes/tests/accept/instantiate.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/instantiate.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/let.lc b/prototypes/tests/accept/let.lc deleted file mode 120000 index fce72e3b..00000000 --- a/prototypes/tests/accept/let.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/let.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/letIndent.lc b/prototypes/tests/accept/letIndent.lc deleted file mode 120000 index ef9d2cc4..00000000 --- a/prototypes/tests/accept/letIndent.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/letIndent.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/line01.lc b/prototypes/tests/accept/line01.lc deleted file mode 120000 index a7dbf6ec..00000000 --- a/prototypes/tests/accept/line01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/line01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/listcompr01.lc b/prototypes/tests/accept/listcompr01.lc deleted file mode 120000 index 9245a221..00000000 --- a/prototypes/tests/accept/listcompr01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/listcompr01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/listcompr02.lc b/prototypes/tests/accept/listcompr02.lc deleted file mode 120000 index 14a8e390..00000000 --- a/prototypes/tests/accept/listcompr02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/listcompr02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/listcompr03.lc b/prototypes/tests/accept/listcompr03.lc deleted file mode 120000 index b612974c..00000000 --- a/prototypes/tests/accept/listcompr03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/listcompr03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/listcompr04.lc b/prototypes/tests/accept/listcompr04.lc deleted file mode 120000 index 0bb81d2c..00000000 --- a/prototypes/tests/accept/listcompr04.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/listcompr04.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/listcompr05.lc b/prototypes/tests/accept/listcompr05.lc deleted file mode 120000 index cd8cacd0..00000000 --- a/prototypes/tests/accept/listcompr05.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/listcompr05.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/point01.lc b/prototypes/tests/accept/point01.lc deleted file mode 120000 index 279582fa..00000000 --- a/prototypes/tests/accept/point01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/point01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/record01.lc b/prototypes/tests/accept/record01.lc deleted file mode 120000 index 22769059..00000000 --- a/prototypes/tests/accept/record01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/record01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/record02.lc b/prototypes/tests/accept/record02.lc deleted file mode 120000 index b6adcf48..00000000 --- a/prototypes/tests/accept/record02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/record02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/recursivetexture02.lc b/prototypes/tests/accept/recursivetexture02.lc deleted file mode 120000 index 97bf2b71..00000000 --- a/prototypes/tests/accept/recursivetexture02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/recursivetexture02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce01.lc b/prototypes/tests/accept/reduce01.lc deleted file mode 120000 index 4907dfa3..00000000 --- a/prototypes/tests/accept/reduce01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce02.lc b/prototypes/tests/accept/reduce02.lc deleted file mode 120000 index 3a26d616..00000000 --- a/prototypes/tests/accept/reduce02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce03.lc b/prototypes/tests/accept/reduce03.lc deleted file mode 120000 index a39bc4b3..00000000 --- a/prototypes/tests/accept/reduce03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce04.lc b/prototypes/tests/accept/reduce04.lc deleted file mode 120000 index 2d6d9cd5..00000000 --- a/prototypes/tests/accept/reduce04.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce04.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce05.lc b/prototypes/tests/accept/reduce05.lc deleted file mode 120000 index 29b9a695..00000000 --- a/prototypes/tests/accept/reduce05.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce05.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/reduce06.lc b/prototypes/tests/accept/reduce06.lc deleted file mode 120000 index d8415c9c..00000000 --- a/prototypes/tests/accept/reduce06.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/reduce06.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/simple02.lc b/prototypes/tests/accept/simple02.lc deleted file mode 120000 index 9daa3328..00000000 --- a/prototypes/tests/accept/simple02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/simple02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/simple03.lc b/prototypes/tests/accept/simple03.lc deleted file mode 120000 index 12f5db1e..00000000 --- a/prototypes/tests/accept/simple03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/simple03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/swizzling.lc b/prototypes/tests/accept/swizzling.lc deleted file mode 120000 index a36ac043..00000000 --- a/prototypes/tests/accept/swizzling.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/swizzling.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/texture01.lc b/prototypes/tests/accept/texture01.lc deleted file mode 120000 index 69504d89..00000000 --- a/prototypes/tests/accept/texture01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/texture01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/texture02.lc b/prototypes/tests/accept/texture02.lc deleted file mode 120000 index ec570de7..00000000 --- a/prototypes/tests/accept/texture02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/texture02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/typeclass0.lc b/prototypes/tests/accept/typeclass0.lc deleted file mode 120000 index 87bfef05..00000000 --- a/prototypes/tests/accept/typeclass0.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/typeclass0.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/uniformparam01.lc b/prototypes/tests/accept/uniformparam01.lc deleted file mode 120000 index 52da0bc6..00000000 --- a/prototypes/tests/accept/uniformparam01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/uniformparam01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/uniformparam02.lc b/prototypes/tests/accept/uniformparam02.lc deleted file mode 120000 index a4337d3a..00000000 --- a/prototypes/tests/accept/uniformparam02.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/uniformparam02.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/uniformparam03.lc b/prototypes/tests/accept/uniformparam03.lc deleted file mode 120000 index 13143d6e..00000000 --- a/prototypes/tests/accept/uniformparam03.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/uniformparam03.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/zip01.lc b/prototypes/tests/accept/zip01.lc deleted file mode 120000 index 8854d4fa..00000000 --- a/prototypes/tests/accept/zip01.lc +++ /dev/null | |||
@@ -1 +0,0 @@ | |||
1 | ../../../tests/accept/zip01.lc \ No newline at end of file | ||
diff --git a/prototypes/tests/demo/.placeholder b/prototypes/tests/demo/.placeholder deleted file mode 100644 index e69de29b..00000000 --- a/prototypes/tests/demo/.placeholder +++ /dev/null | |||
diff --git a/prototypes/tests/reject/.placeholder b/prototypes/tests/reject/.placeholder deleted file mode 100644 index e69de29b..00000000 --- a/prototypes/tests/reject/.placeholder +++ /dev/null | |||
diff --git a/prototypes/run-test-suite.sh b/run-test-suite.sh index 9ced8e55..9ced8e55 100755 --- a/prototypes/run-test-suite.sh +++ b/run-test-suite.sh | |||
diff --git a/runTests.hs b/runTests.hs index ce15ebbd..c8bd3177 100644 --- a/runTests.hs +++ b/runTests.hs | |||
@@ -16,9 +16,7 @@ import Control.Monad.Catch | |||
16 | import Control.DeepSeq | 16 | import Control.DeepSeq |
17 | 17 | ||
18 | import Pretty hiding ((</>)) | 18 | import Pretty hiding ((</>)) |
19 | import Type | 19 | import CGExp |
20 | import Typecheck | ||
21 | import Parser | ||
22 | import Driver | 20 | import Driver |
23 | import CoreToIR | 21 | import CoreToIR |
24 | import IR (Backend(..)) | 22 | import IR (Backend(..)) |
diff --git a/tests/accept/Builtins.lc b/tests/accept/Builtins.lc index f0df2726..187a6e9e 100644 --- a/tests/accept/Builtins.lc +++ b/tests/accept/Builtins.lc | |||
@@ -1,5 +1,21 @@ | |||
1 | {-# LANGUAGE NoImplicitPrelude #-} | 1 | {-# LANGUAGE NoImplicitPrelude #-} |
2 | module Builtins where | 2 | -- module Builtins where |
3 | |||
4 | builtins | ||
5 | cstr :: Type -> Type -> Type | ||
6 | -- reflCstr :: forall (a :: Type) -> cstr a a | ||
7 | T2 :: Type -> Type -> Type | ||
8 | T2C :: Unit -> Unit -> Unit | ||
9 | |||
10 | data Unit = TT | ||
11 | |||
12 | -- TODO: generate? | ||
13 | data Tuple0 = Tuple0 | ||
14 | data Tuple1 a = Tuple1 a | ||
15 | data Tuple2 a b = Tuple2 a b | ||
16 | data Tuple3 a b c = Tuple3 a b c | ||
17 | data Tuple4 a b c d = Tuple4 a b c d | ||
18 | data Tuple5 a b c d e = Tuple5 a b c d e | ||
3 | 19 | ||
4 | id x = x | 20 | id x = x |
5 | 21 | ||
@@ -7,18 +23,22 @@ data Bool = False | True | |||
7 | 23 | ||
8 | data Ordering = LT | EQ | GT | 24 | data Ordering = LT | EQ | GT |
9 | 25 | ||
10 | builtins | 26 | primIfThenElse :: Bool -> a -> a -> a |
11 | PrimIfThenElse :: Bool -> a -> a -> a | 27 | primIfThenElse True a b = a |
28 | primIfThenElse False a b = b | ||
12 | 29 | ||
13 | --------------------------------------- | 30 | --------------------------------------- |
14 | 31 | ||
15 | data Nat where | 32 | data Nat = Zero | Succ Nat |
16 | data Int where | ||
17 | data Word where | ||
18 | data Float where | ||
19 | data Char where | ||
20 | data String where | ||
21 | 33 | ||
34 | builtintycons | ||
35 | Int :: Type | ||
36 | Word :: Type | ||
37 | Float :: Type | ||
38 | Char :: Type | ||
39 | String :: Type | ||
40 | |||
41 | {- | ||
22 | type family TFVec (n :: Nat) a -- may be a data family | 42 | type family TFVec (n :: Nat) a -- may be a data family |
23 | type family VecScalar (n :: Nat) a | 43 | type family VecScalar (n :: Nat) a |
24 | type family TFMat i j -- may be a data family | 44 | type family TFMat i j -- may be a data family |
@@ -32,16 +52,34 @@ type family JoinTupleType t1 t2 | |||
32 | class AttributeTuple a | 52 | class AttributeTuple a |
33 | class ValidOutput a | 53 | class ValidOutput a |
34 | class ValidFrameBuffer a | 54 | class ValidFrameBuffer a |
55 | -} | ||
56 | builtins | ||
57 | TFVec :: Nat -> Type -> Type | ||
58 | VecScalar :: Nat -> Type -> Type | ||
59 | TFMat :: Type -> Type -> Type | ||
60 | MatVecElem :: Type -> Type | ||
61 | MatVecScalarElem :: Type -> Type | ||
62 | FTRepr' :: Type -> Type | ||
63 | ColorRepr :: Type -> Type | ||
64 | TFFrameBuffer :: Type -> Type | ||
65 | FragOps :: Type -> Type | ||
66 | JoinTupleType :: Type -> Type -> Type | ||
67 | |||
68 | AttributeTuple :: Type -> Type | ||
69 | ValidOutput :: Type -> Type | ||
70 | ValidFrameBuffer :: Type -> Type | ||
71 | |||
72 | data VecS (a :: Type) :: Nat -> Type where | ||
73 | V2 :: a -> a -> VecS a 2 | ||
74 | V3 :: a -> a -> a -> VecS a 3 | ||
75 | V4 :: a -> a -> a -> a -> VecS a 4 | ||
35 | 76 | ||
36 | data Vec (n :: Nat) a where | 77 | builtins |
37 | V2 :: a -> a -> Vec 2 a | 78 | Vec :: Nat -> Type -> Type |
38 | V3 :: a -> a -> a -> Vec 3 a | 79 | --Vec n t = VecS t n |
39 | V4 :: a -> a -> a -> a -> Vec 4 a | ||
40 | 80 | ||
41 | -- builtins | ||
42 | -- V1 :: a -> Vec 2 a -- TODO: eliminate | ||
43 | 81 | ||
44 | data Mat (i :: Nat) (j :: Nat) a where | 82 | data Mat :: Nat -> Nat -> Type -> Type where |
45 | M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float | 83 | M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float |
46 | M23F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 3 Float | 84 | M23F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 3 Float |
47 | M24F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 4 Float | 85 | M24F :: Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float -> Mat 2 4 Float |
@@ -52,6 +90,29 @@ data Mat (i :: Nat) (j :: Nat) a where | |||
52 | M43F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 3 Float | 90 | M43F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 3 Float |
53 | M44F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 4 Float | 91 | M44F :: Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Vec 4 Float -> Mat 4 4 Float |
54 | 92 | ||
93 | |||
94 | builtins | ||
95 | CNum, Signed, Num, Component, Integral, NumComponent, Floating :: Type -> Type | ||
96 | |||
97 | fromInt :: Num a => Int -> a | ||
98 | compare :: Num a => a -> a -> Ordering | ||
99 | negate :: Num a => a -> a | ||
100 | |||
101 | vec2 :: Component a => a -> a -> Vec 2 a | ||
102 | vec3 :: Component a => a -> a -> a -> Vec 3 a | ||
103 | vec4 :: Component a => a -> a -> a -> a -> Vec 4 a | ||
104 | zeroComp :: Component a => a | ||
105 | oneComp :: Component a => a | ||
106 | |||
107 | --------------------------------------- swizzling | ||
108 | |||
109 | data Swizz = Sx | Sy | Sz | Sw | ||
110 | |||
111 | builtins | ||
112 | swizzvector :: forall n . forall m . Vec n a -> Vec m Swizz -> Vec m a | ||
113 | swizzscalar :: forall n . Vec n a -> Swizz -> a | ||
114 | |||
115 | {- | ||
55 | --------------------------------------- type classes | 116 | --------------------------------------- type classes |
56 | 117 | ||
57 | class CNum a | 118 | class CNum a |
@@ -68,7 +129,7 @@ class Num a where | |||
68 | fromInt :: Int -> a | 129 | fromInt :: Int -> a |
69 | compare :: a -> a -> Ordering | 130 | compare :: a -> a -> Ordering |
70 | negate :: a -> a | 131 | negate :: a -> a |
71 | 132 | -} | |
72 | builtins | 133 | builtins |
73 | primIntToWord :: Int -> Word | 134 | primIntToWord :: Int -> Word |
74 | primIntToFloat :: Int -> Float | 135 | primIntToFloat :: Int -> Float |
@@ -79,6 +140,7 @@ builtins | |||
79 | primNegateWord :: Word -> Word | 140 | primNegateWord :: Word -> Word |
80 | primNegateFloat :: Float -> Float | 141 | primNegateFloat :: Float -> Float |
81 | 142 | ||
143 | {- | ||
82 | instance Num Int where | 144 | instance Num Int where |
83 | fromInt = id | 145 | fromInt = id |
84 | compare = primCompareInt | 146 | compare = primCompareInt |
@@ -158,7 +220,6 @@ instance Component (Vec 4 Bool) where | |||
158 | zeroComp = V4 False False False False | 220 | zeroComp = V4 False False False False |
159 | oneComp = V4 True True True True | 221 | oneComp = V4 True True True True |
160 | 222 | ||
161 | |||
162 | class Integral a | 223 | class Integral a |
163 | 224 | ||
164 | instance Integral Int | 225 | instance Integral Int |
@@ -188,10 +249,10 @@ instance Floating (Mat 3 4 Float) | |||
188 | instance Floating (Mat 4 2 Float) | 249 | instance Floating (Mat 4 2 Float) |
189 | instance Floating (Mat 4 3 Float) | 250 | instance Floating (Mat 4 3 Float) |
190 | instance Floating (Mat 4 4 Float) | 251 | instance Floating (Mat 4 4 Float) |
191 | 252 | -} | |
192 | 253 | ||
193 | data BlendingFactor | 254 | data BlendingFactor |
194 | = Zero' | 255 | = Zero' --- FIXME: modified |
195 | | One | 256 | | One |
196 | | SrcColor | 257 | | SrcColor |
197 | | OneMinusSrcColor | 258 | | OneMinusSrcColor |
@@ -294,29 +355,29 @@ data PrimitiveType | |||
294 | | TriangleAdjacency | 355 | | TriangleAdjacency |
295 | | LineAdjacency | 356 | | LineAdjacency |
296 | 357 | ||
297 | builtins | 358 | builtincons |
298 | PrimTexture :: () -> Vec 2 Float -> Vec 4 Float | 359 | PrimTexture :: () -> Vec 2 Float -> Vec 4 Float |
299 | 360 | ||
300 | builtins | 361 | builtincons |
301 | Uniform :: String -> t | 362 | Uniform :: String -> t |
302 | Attribute :: String -> t | 363 | Attribute :: String -> t |
303 | 364 | ||
304 | data FragmentOut a where | 365 | data FragmentOut a where |
305 | FragmentOut :: (a ~ ColorRepr t) => t -> FragmentOut a | 366 | FragmentOut :: (a ~ ColorRepr t) => t -> FragmentOut a |
306 | FragmentOutDepth :: (a ~ ColorRepr t, b ~ JoinTupleType (Depth Float) a) => Float -> t | 367 | FragmentOutDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => Float -> t |
307 | -> FragmentOut b | 368 | -> FragmentOut a |
308 | FragmentOutRastDepth :: (a ~ ColorRepr t, b ~ JoinTupleType (Depth Float) a) => t | 369 | FragmentOutRastDepth :: (x ~ ColorRepr t, a ~ JoinTupleType (Depth Float) x) => t |
309 | -> FragmentOut b | 370 | -> FragmentOut a |
310 | 371 | ||
311 | data VertexOut a where | 372 | data VertexOut a where |
312 | VertexOut :: (t ~ FTRepr' a) => Vec 4 Float -> Float -> (){-TODO-} -> a -> VertexOut t | 373 | VertexOut :: (a ~ FTRepr' x) => Vec 4 Float -> Float -> (){-TODO-} -> x -> VertexOut a |
313 | 374 | ||
314 | data RasterContext (a :: PrimitiveType) where | 375 | data RasterContext :: PrimitiveType -> Type where |
315 | TriangleCtx :: CullMode -> PolygonMode -> PolygonOffset -> ProvokingVertex -> RasterContext Triangle | 376 | TriangleCtx :: CullMode -> PolygonMode -> PolygonOffset -> ProvokingVertex -> RasterContext Triangle |
316 | PointCtx :: PointSize -> Float -> PointSpriteCoordOrigin -> RasterContext Point | 377 | PointCtx :: PointSize -> Float -> PointSpriteCoordOrigin -> RasterContext Point |
317 | LineCtx :: Float -> ProvokingVertex -> RasterContext Line | 378 | LineCtx :: Float -> ProvokingVertex -> RasterContext Line |
318 | 379 | ||
319 | data FetchPrimitive (a :: PrimitiveType) where | 380 | data FetchPrimitive :: PrimitiveType -> Type where |
320 | Points :: FetchPrimitive Point | 381 | Points :: FetchPrimitive Point |
321 | Lines :: FetchPrimitive Line | 382 | Lines :: FetchPrimitive Line |
322 | Triangles :: FetchPrimitive Triangle | 383 | Triangles :: FetchPrimitive Triangle |
@@ -324,20 +385,20 @@ data FetchPrimitive (a :: PrimitiveType) where | |||
324 | TrianglesAdjacency :: FetchPrimitive TriangleAdjacency | 385 | TrianglesAdjacency :: FetchPrimitive TriangleAdjacency |
325 | 386 | ||
326 | data AccumulationContext a where | 387 | data AccumulationContext a where |
327 | AccumulationContext :: (t' ~ FragOps t) => t -> AccumulationContext t' | 388 | AccumulationContext :: (a ~ FragOps t) => t -> AccumulationContext a |
328 | 389 | ||
329 | data Image (a :: Nat) b{-Semantic-} where | 390 | data Image (a :: Nat) :: Type -> Type where |
330 | ColorImage :: (Num t, color ~ VecScalar d t) | 391 | ColorImage :: (Num t, color ~ VecScalar d t) |
331 | => forall (a :: Nat) . color -> Image a (Color color) | 392 | => color -> Image a (Color color) |
332 | DepthImage :: forall (a :: Nat) . Float -> Image a (Depth Float) | 393 | DepthImage :: Float -> Image a (Depth Float) |
333 | StencilImage :: forall (a :: Nat) . Int -> Image a (Stencil Int) | 394 | StencilImage :: Int -> Image a (Stencil Int) |
334 | 395 | ||
335 | data Interpolated t where | 396 | data Interpolated t where |
336 | Smooth, NoPerspective | 397 | Smooth, NoPerspective |
337 | :: (Floating t) => t -> Interpolated t | 398 | :: (Floating t) => t -> Interpolated t |
338 | Flat :: t -> Interpolated t | 399 | Flat :: t -> Interpolated t |
339 | 400 | ||
340 | data Blending a where | 401 | data Blending :: Type -> Type where |
341 | NoBlending :: Blending t | 402 | NoBlending :: Blending t |
342 | BlendLogicOp :: (Integral t) => LogicOperation -> Blending t | 403 | BlendLogicOp :: (Integral t) => LogicOperation -> Blending t |
343 | Blend :: (BlendEquation, BlendEquation) | 404 | Blend :: (BlendEquation, BlendEquation) |
@@ -349,28 +410,29 @@ data Blending a where | |||
349 | FragmentOut :: Semantic -> * | 410 | FragmentOut :: Semantic -> * |
350 | VertexOut :: ??? | 411 | VertexOut :: ??? |
351 | -} | 412 | -} |
352 | data FragmentOperation a where | 413 | |
414 | data FragmentOperation :: Type -> Type where | ||
353 | ColorOp :: (mask ~ VecScalar d Bool, color ~ VecScalar d c, Num c) => Blending c -> mask | 415 | ColorOp :: (mask ~ VecScalar d Bool, color ~ VecScalar d c, Num c) => Blending c -> mask |
354 | -> FragmentOperation (Color color) | 416 | -> FragmentOperation (Color color) |
355 | DepthOp :: ComparisonFunction -> Bool -> FragmentOperation (Depth Float) | 417 | DepthOp :: ComparisonFunction -> Bool -> FragmentOperation (Depth Float) |
356 | -- StencilOp :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation (Stencil Int32) | 418 | StencilOp :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation (Stencil Int32) |
357 | 419 | ||
358 | data FragmentFilter t where | 420 | data FragmentFilter t where |
359 | PassAll :: FragmentFilter t | 421 | PassAll :: FragmentFilter t |
360 | Filter :: (t -> Bool) -> FragmentFilter t | 422 | Filter :: (t -> Bool) -> FragmentFilter t |
361 | 423 | ||
362 | data VertexStream (a :: PrimitiveType) b where | 424 | data VertexStream (a :: PrimitiveType) t where |
363 | Fetch :: (AttributeTuple t) => String -> FetchPrimitive a -> t -> VertexStream a t | 425 | Fetch :: (AttributeTuple t) => String -> FetchPrimitive a -> t -> VertexStream a t |
364 | FetchArrays :: (AttributeTuple t, t ~ FTRepr' t') => FetchPrimitive a -> t' -> VertexStream a t | 426 | FetchArrays :: (AttributeTuple t, t ~ FTRepr' t') => FetchPrimitive a -> t' -> VertexStream a t |
365 | 427 | ||
366 | data PrimitiveStream (p :: PrimitiveType) (n :: Nat) b where | 428 | data PrimitiveStream (p :: PrimitiveType) :: Nat -> Type -> Type where |
367 | Transform :: (a -> VertexOut b) -> VertexStream p a -> PrimitiveStream p 1 b | 429 | Transform :: (a -> VertexOut b) -> VertexStream p a -> PrimitiveStream p 1 b |
368 | 430 | ||
369 | -- Render Operations | 431 | -- Render Operations |
370 | data FragmentStream (n :: Nat) a where | 432 | data FragmentStream (n :: Nat) a where |
371 | Rasterize :: RasterContext a -> PrimitiveStream a b c -> FragmentStream b c | 433 | Rasterize :: RasterContext x -> PrimitiveStream x n a -> FragmentStream n a |
372 | 434 | ||
373 | data FrameBuffer (n :: Nat) a where | 435 | data FrameBuffer (n :: Nat) b where |
374 | Accumulate :: (ValidOutput b) => | 436 | Accumulate :: (ValidOutput b) => |
375 | AccumulationContext b | 437 | AccumulationContext b |
376 | -> FragmentFilter a | 438 | -> FragmentFilter a |
@@ -378,8 +440,10 @@ data FrameBuffer (n :: Nat) a where | |||
378 | -> FragmentStream n a | 440 | -> FragmentStream n a |
379 | -> FrameBuffer n b | 441 | -> FrameBuffer n b |
380 | -> FrameBuffer n b | 442 | -> FrameBuffer n b |
381 | FrameBuffer :: (ValidFrameBuffer t, FrameBuffer n t ~ TFFrameBuffer a) | 443 | |
382 | => a -> FrameBuffer n t | 444 | FrameBuffer :: (ValidFrameBuffer b, FrameBuffer n b ~ TFFrameBuffer a) |
445 | => a -> FrameBuffer n b | ||
446 | |||
383 | 447 | ||
384 | data Output where | 448 | data Output where |
385 | ScreenOut :: FrameBuffer a b -> Output | 449 | ScreenOut :: FrameBuffer a b -> Output |
@@ -388,33 +452,33 @@ builtins | |||
388 | -- * Primitive Functions * | 452 | -- * Primitive Functions * |
389 | -- Arithmetic Functions (componentwise) | 453 | -- Arithmetic Functions (componentwise) |
390 | 454 | ||
391 | PrimAdd, PrimSub, PrimMul :: (t ~ MatVecElem a, Num t) => a -> a -> a | 455 | PrimAdd, PrimSub, PrimMul :: (t ~ MatVecElem a, Num t) => a -> a -> a |
392 | PrimAddS, PrimSubS, PrimMulS :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a | 456 | PrimAddS, PrimSubS, PrimMulS :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a |
393 | PrimDiv, PrimMod :: (Num t, a ~ VecScalar d t) => a -> a -> a | 457 | PrimDiv, PrimMod :: (Num t, a ~ VecScalar d t) => a -> a -> a |
394 | PrimDivS, PrimModS :: (Num t, a ~ VecScalar d t) => a -> t -> a | 458 | PrimDivS, PrimModS :: (Num t, a ~ VecScalar d t) => a -> t -> a |
395 | PrimNeg :: (t ~ MatVecScalarElem a, Signed t) => a -> a | 459 | PrimNeg :: (t ~ MatVecScalarElem a, Signed t) => a -> a |
396 | -- Bit-wise Functions | 460 | -- Bit-wise Functions |
397 | PrimBAnd, PrimBOr, PrimBXor :: (Integral t, a ~ VecScalar d t) => a -> a -> a | 461 | PrimBAnd, PrimBOr, PrimBXor :: (Integral t, a ~ VecScalar d t) => a -> a -> a |
398 | PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a | 462 | PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a |
399 | PrimBNot :: (Integral t, a ~ VecScalar d t) => a -> a | 463 | PrimBNot :: (Integral t, a ~ VecScalar d t) => a -> a |
400 | PrimBShiftL, PrimBShiftR :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a | 464 | PrimBShiftL, PrimBShiftR :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a |
401 | PrimBShiftLS, PrimBShiftRS :: (Integral t, a ~ VecScalar d t) => a -> Word -> a | 465 | PrimBShiftLS, PrimBShiftRS :: (Integral t, a ~ VecScalar d t) => a -> Word -> a |
402 | -- Logic Functions | 466 | -- Logic Functions |
403 | PrimAnd, PrimOr, PrimXor :: Bool -> Bool -> Bool | 467 | PrimAnd, PrimOr, PrimXor :: Bool -> Bool -> Bool |
404 | PrimNot :: (a ~ VecScalar d Bool) => a -> a | 468 | PrimNot :: (a ~ VecScalar d Bool) => a -> a |
405 | PrimAny, PrimAll :: (a ~ VecScalar d Bool) => a -> Bool | 469 | PrimAny, PrimAll :: (a ~ VecScalar d Bool) => a -> Bool |
406 | 470 | ||
407 | -- Angle, Trigonometry and Exponential Functions | 471 | -- Angle, Trigonometry and Exponential Functions |
408 | PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt | 472 | PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt |
409 | :: (a ~ VecScalar d Float) => a -> a | 473 | :: (a ~ VecScalar d Float) => a -> a |
410 | PrimPow, PrimATan2 :: (a ~ VecScalar d Float) => a -> a -> a | 474 | PrimPow, PrimATan2 :: (a ~ VecScalar d Float) => a -> a -> a |
411 | --ommon Functions | 475 | -- Common Functions |
412 | PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract | 476 | PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract |
413 | :: (a ~ VecScalar d Float) => a -> a | 477 | :: (a ~ VecScalar d Float) => a -> a |
414 | PrimMin, PrimMax :: (Num t, a ~ VecScalar d t) => a -> a -> a | 478 | PrimMin, PrimMax :: (Num t, a ~ VecScalar d t) => a -> a -> a |
415 | PrimMinS, PrimMaxS :: (Num t, a ~ VecScalar d t) => a -> t -> a | 479 | PrimMinS, PrimMaxS :: (Num t, a ~ VecScalar d t) => a -> t -> a |
416 | PrimIsNan, PrimIsInf :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b | 480 | PrimIsNan, PrimIsInf :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b |
417 | PrimAbs, PrimSign :: (Signed t, a ~ VecScalar d t) => a -> a | 481 | PrimAbs, PrimSign :: (Signed t, a ~ VecScalar d t) => a -> a |
418 | PrimModF :: (a ~ VecScalar d Float) => a -> (a, a) | 482 | PrimModF :: (a ~ VecScalar d Float) => a -> (a, a) |
419 | PrimClamp :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a | 483 | PrimClamp :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a |
420 | PrimClampS :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a | 484 | PrimClampS :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a |
@@ -434,11 +498,11 @@ builtins | |||
434 | -- Geometric Functions | 498 | -- Geometric Functions |
435 | PrimLength :: (a ~ VecScalar d Float) => a -> Float | 499 | PrimLength :: (a ~ VecScalar d Float) => a -> Float |
436 | PrimDistance, PrimDot | 500 | PrimDistance, PrimDot |
437 | :: (a ~ VecScalar d Float) => a -> a -> Float | 501 | :: (a ~ VecScalar d Float) => a -> a -> Float |
438 | PrimCross :: (a ~ VecScalar 3 Float) => a -> a -> a | 502 | PrimCross :: (a ~ VecScalar 3 Float) => a -> a -> a |
439 | PrimNormalize :: (a ~ VecScalar d Float) => a -> a | 503 | PrimNormalize :: (a ~ VecScalar d Float) => a -> a |
440 | PrimFaceForward, PrimRefract | 504 | PrimFaceForward, PrimRefract |
441 | :: (a ~ VecScalar d Float) => a -> a -> a -> a | 505 | :: (a ~ VecScalar d Float) => a -> a -> a -> a |
442 | PrimReflect :: (a ~ VecScalar d Float) => a -> a -> a | 506 | PrimReflect :: (a ~ VecScalar d Float) => a -> a -> a |
443 | -- Matrix Functions | 507 | -- Matrix Functions |
444 | PrimTranspose :: (a ~ TFMat h w, b ~ TFMat w h) => a -> b | 508 | PrimTranspose :: (a ~ TFMat h w, b ~ TFMat w h) => a -> b |
@@ -450,12 +514,12 @@ builtins | |||
450 | PrimMulMatMat :: (a ~ TFMat i j, b ~ TFMat j k, c ~ TFMat i k) => a -> b -> c | 514 | PrimMulMatMat :: (a ~ TFMat i j, b ~ TFMat j k, c ~ TFMat i k) => a -> b -> c |
451 | -- Vector and Scalar Relational Functions | 515 | -- Vector and Scalar Relational Functions |
452 | PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV | 516 | PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV |
453 | :: (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b | 517 | :: (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b |
454 | PrimEqual, PrimNotEqual | 518 | PrimEqual, PrimNotEqual |
455 | :: (t ~ MatVecScalarElem a) => a -> a -> Bool | 519 | :: (t ~ MatVecScalarElem a) => a -> a -> Bool |
456 | -- Fragment Processing Functions | 520 | -- Fragment Processing Functions |
457 | PrimDFdx, PrimDFdy, PrimFWidth | 521 | PrimDFdx, PrimDFdy, PrimFWidth |
458 | :: (a ~ VecScalar d Float) => a -> a | 522 | :: (a ~ VecScalar d Float) => a -> a |
459 | -- Noise Functions | 523 | -- Noise Functions |
460 | PrimNoise1 :: (a ~ VecScalar d Float) => a -> Float | 524 | PrimNoise1 :: (a ~ VecScalar d Float) => a -> Float |
461 | PrimNoise2 :: (a ~ VecScalar d Float, b ~ VecScalar 2 Float) => a -> b | 525 | PrimNoise2 :: (a ~ VecScalar d Float, b ~ VecScalar 2 Float) => a -> b |
@@ -476,7 +540,7 @@ builtins | |||
476 | -- * Texture support | 540 | -- * Texture support |
477 | -- FIXME: currently only Float RGBA 2D texture is supported | 541 | -- FIXME: currently only Float RGBA 2D texture is supported |
478 | 542 | ||
479 | builtins | 543 | builtincons |
480 | PrjImage :: FrameBuffer 1 a -> Image 1 a | 544 | PrjImage :: FrameBuffer 1 a -> Image 1 a |
481 | PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float)) | 545 | PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float)) |
482 | 546 | ||
@@ -499,5 +563,6 @@ data EdgeMode | |||
499 | 563 | ||
500 | data Sampler = Sampler Filter EdgeMode Texture | 564 | data Sampler = Sampler Filter EdgeMode Texture |
501 | 565 | ||
502 | builtins | 566 | builtincons |
503 | texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float | 567 | texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float |
568 | |||
diff --git a/prototypes/tests/accept/DepPrelude.lc b/tests/accept/DepPrelude.lc index facb4b7b..facb4b7b 100644 --- a/prototypes/tests/accept/DepPrelude.lc +++ b/tests/accept/DepPrelude.lc | |||
diff --git a/tests/accept/Graphics.out b/tests/accept/Graphics.out index 7d6eefb5..3fa5594e 100644 --- a/tests/accept/Graphics.out +++ b/tests/accept/Graphics.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("t01453",Parameter {name = "position", ty = V3F}),("t01454",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 t01453 ;\nin vec4 t01454 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t01454;\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( t01453 ).x,( t01453 ).y,( t01453 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( ( 1.0 ) - ( ( v0 ).x ),( 1.0 ) - ( ( v0 ).y ),( 1.0 ) - ( ( v0 ).z ),1.0 );\n}\n"},Program {programUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("t01357",Parameter {name = "position", ty = V3F}),("t01358",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 t01357 ;\nin vec4 t01358 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( ( t01358 ).x,( t01358 ).y,( t01358 ).z,0.5 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( t01357 ).x,( t01357 ).y,( t01357 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("t01125",Parameter {name = "position", ty = V3F}),("t01126",Parameter {name = "normal", ty = V3F}),("t01127",Parameter {name = "diffuseUV", ty = V2F}),("t01128",Parameter {name = "lightmapUV", ty = V2F}),("t01129",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 t01125 ;\nin vec3 t01126 ;\nin vec2 t01127 ;\nin vec2 t01128 ;\nin vec4 t01129 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = t01127;\nv1 = vec4 ( ( ( vec3 ( ( t01129 ).x,( t01129 ).y,( t01129 ).z ) ) * ( identityLight ) ).x,( ( vec3 ( ( t01129 ).x,( t01129 ).y,( t01129 ).z ) ) * ( identityLight ) ).y,( ( vec3 ( ( t01129 ).x,( t01129 ).y,( t01129 ).z ) ) * ( identityLight ) ).z,( t01129 ).w );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( t01125 ).x,( t01125 ).y,( t01125 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler0 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler0,v0 ) );\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("t01125",Parameter {name = "position", ty = V3F}),("t01126",Parameter {name = "normal", ty = V3F}),("t01127",Parameter {name = "diffuseUV", ty = V2F}),("t01128",Parameter {name = "lightmapUV", ty = V2F}),("t01129",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 t01125 ;\nin vec3 t01126 ;\nin vec2 t01127 ;\nin vec2 t01128 ;\nin vec4 t01129 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = t01128;\nv1 = vec4 ( identityLight,identityLight,identityLight,1.0 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( t01125 ).x,( t01125 ).y,( t01125 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler1 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler1,v0 ) );\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("t01125",Parameter {name = "position", ty = V3F}),("t01126",Parameter {name = "normal", ty = V3F}),("t01127",Parameter {name = "diffuseUV", ty = V2F}),("t01128",Parameter {name = "lightmapUV", ty = V2F}),("t01129",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 t01125 ;\nin vec3 t01126 ;\nin vec2 t01127 ;\nin vec2 t01128 ;\nin vec4 t01129 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = t01127;\nv1 = vec4 ( identityLight,identityLight,identityLight,1.0 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( t01125 ).x,( t01125 ).y,( t01125 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler2 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler2,v0 ) );\n}\n"}], slots = [Slot {slotName = "missing shader", slotStreams = fromList [("color",V4F),("position",V3F)], slotUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]},Slot {slotName = "models/mapobjects/gratelamp/gratetorch2b", slotStreams = fromList [("color",V4F),("diffuseUV",V2F),("lightmapUV",V2F),("normal",V3F),("position",V3F)], slotUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [2]},Slot {slotName = "models/mapobjects/gratelamp/gratetorch2", slotStreams = fromList [("color",V4F),("diffuseUV",V2F),("lightmapUV",V2F),("normal",V3F),("position",V3F)], slotUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [3,4]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.0 0.0)}],SetProgram 4,SetRasterContext (TriangleCtx (CullFront CCW) PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 2,SetProgram 3,SetRasterContext (TriangleCtx (CullFront CCW) PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = DstColor, colorFDst = Zero, alphaFSrc = DstColor, alphaFDst = Zero, color = V4 0.0 0.0 0.0 0.0}) (VV4B (V4 True True True True))]}),RenderSlot 2,SetProgram 2,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 1,SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = Min, colorFSrc = One, colorFDst = One, alphaFSrc = One, alphaFDst = One, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 1.0) NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("e14",Parameter {name = "position", ty = V3F}),("k14",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 e14 ;\nin vec4 k14 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = k14;\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( e14 ).x,( e14 ).y,( e14 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( ( 1.0 ) - ( ( v0 ).x ),( 1.0 ) - ( ( v0 ).y ),( 1.0 ) - ( ( v0 ).z ),1.0 );\n}\n"},Program {programUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("i36",Parameter {name = "position", ty = V3F}),("o36",Parameter {name = "color", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 i36 ;\nin vec4 o36 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( ( o36 ).x,( o36 ).y,( o36 ).z,0.5 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( i36 ).x,( i36 ).y,( i36 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("d73",Parameter {name = "lightmapUV", ty = V2F}),("i73",Parameter {name = "color", ty = V4F}),("m72",Parameter {name = "position", ty = V3F}),("s72",Parameter {name = "normal", ty = V3F}),("y72",Parameter {name = "diffuseUV", ty = V2F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 m72 ;\nin vec3 s72 ;\nin vec2 y72 ;\nin vec2 d73 ;\nin vec4 i73 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = y72;\nv1 = vec4 ( ( ( vec3 ( ( i73 ).x,( i73 ).y,( i73 ).z ) ) * ( identityLight ) ).x,( ( vec3 ( ( i73 ).x,( i73 ).y,( i73 ).z ) ) * ( identityLight ) ).y,( ( vec3 ( ( i73 ).x,( i73 ).y,( i73 ).z ) ) * ( identityLight ) ).z,( i73 ).w );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( m72 ).x,( m72 ).y,( m72 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler0 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler0,v0 ) );\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("a112",Parameter {name = "color", ty = V4F}),("e111",Parameter {name = "position", ty = V3F}),("k111",Parameter {name = "normal", ty = V3F}),("q111",Parameter {name = "diffuseUV", ty = V2F}),("v111",Parameter {name = "lightmapUV", ty = V2F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 e111 ;\nin vec3 k111 ;\nin vec2 q111 ;\nin vec2 v111 ;\nin vec4 a112 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = v111;\nv1 = vec4 ( identityLight,identityLight,identityLight,1.0 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( e111 ).x,( e111 ).y,( e111 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler1 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler1,v0 ) );\n}\n"},Program {programUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], programStreams = fromList [("d145",Parameter {name = "lightmapUV", ty = V2F}),("i145",Parameter {name = "color", ty = V4F}),("m144",Parameter {name = "position", ty = V3F}),("s144",Parameter {name = "normal", ty = V3F}),("y144",Parameter {name = "diffuseUV", ty = V2F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform float identityLight ;\nuniform mat4 viewProj ;\nuniform mat4 worldMat ;\nin vec3 m144 ;\nin vec3 s144 ;\nin vec2 y144 ;\nin vec2 d145 ;\nin vec4 i145 ;\nsmooth out vec2 v0 ;\nsmooth out vec4 v1 ;\nvoid main() {\nv0 = y144;\nv1 = vec4 ( identityLight,identityLight,identityLight,1.0 );\ngl_Position = ( viewProj ) * ( ( worldMat ) * ( vec4 ( ( m144 ).x,( m144 ).y,( m144 ).z,1.0 ) ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler2 ;\nsmooth in vec2 v0 ;\nsmooth in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v1 ) * ( texture2D ( sampler2,v0 ) );\n}\n"}], slots = [Slot {slotName = "missing shader", slotStreams = fromList [("color",V4F),("position",V3F)], slotUniforms = fromList [("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]},Slot {slotName = "models/mapobjects/gratelamp/gratetorch2b", slotStreams = fromList [("color",V4F),("diffuseUV",V2F),("lightmapUV",V2F),("normal",V3F),("position",V3F)], slotUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [2]},Slot {slotName = "models/mapobjects/gratelamp/gratetorch2", slotStreams = fromList [("color",V4F),("diffuseUV",V2F),("lightmapUV",V2F),("normal",V3F),("position",V3F)], slotUniforms = fromList [("identityLight",Float),("viewProj",M44F),("worldMat",M44F)], slotPrimitive = Triangles, slotPrograms = [3,4]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.0 0.0)}],SetProgram 4,SetRasterContext (TriangleCtx (CullFront CCW) PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 2,SetProgram 3,SetRasterContext (TriangleCtx (CullFront CCW) PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = DstColor, colorFDst = Zero, alphaFSrc = DstColor, alphaFDst = Zero, color = V4 0.0 0.0 0.0 0.0}) (VV4B (V4 True True True True))]}),RenderSlot 2,SetProgram 2,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 1,SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = Min, colorFSrc = One, colorFDst = One, alphaFSrc = One, alphaFDst = One, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 1.0) NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/NewStyle.out b/tests/accept/NewStyle.out index 682c8c44..f8cba51b 100644 --- a/tests/accept/NewStyle.out +++ b/tests/accept/NewStyle.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = v;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 0.5,0.5,0.5,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.1 0.0 0.2 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("s9",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 s9 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = s9;\ngl_Position = ( ( MVP ) * ( s9 ) ) * ( vec4 ( 0.5,0.5,0.5,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.1 0.0 0.2 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/Prelude.lc b/tests/accept/Prelude.lc index 3fe241e8..35d27f0a 100644 --- a/tests/accept/Prelude.lc +++ b/tests/accept/Prelude.lc | |||
@@ -17,13 +17,18 @@ const x y = x | |||
17 | 17 | ||
18 | otherwise = True | 18 | otherwise = True |
19 | 19 | ||
20 | undefined = undefined | 20 | --undefined = undefined |
21 | |||
22 | builtins | ||
23 | undefined :: forall (a :: Type) . a | ||
21 | 24 | ||
22 | x & f = f x | 25 | x & f = f x |
23 | ($) = \f1 x -> f1 x | 26 | |
24 | (.) = \f2 g x -> f2 (g x) | 27 | ($) = \f x -> f x |
28 | (.) = \f g x -> f (g x) | ||
25 | 29 | ||
26 | uncurry f (x, y) = f x y | 30 | uncurry f (x, y) = f x y |
31 | |||
27 | (***) f g (x, y) = (f x, g y) | 32 | (***) f g (x, y) = (f x, g y) |
28 | 33 | ||
29 | data List a = Nil | Cons a (List a) | 34 | data List a = Nil | Cons a (List a) |
@@ -31,9 +36,9 @@ data List a = Nil | Cons a (List a) | |||
31 | pi = 3.14 | 36 | pi = 3.14 |
32 | 37 | ||
33 | zip :: [a] -> [b] -> [(a,b)] | 38 | zip :: [a] -> [b] -> [(a,b)] |
34 | zip [] _ = [] | 39 | zip [] xs = [] |
35 | zip _ [] = [] | 40 | zip xs [] = [] |
36 | zip (a:as) (b:bs) = (a,b) : zip as bs | 41 | zip (a: as) (b: bs) = (a,b): zip as bs |
37 | 42 | ||
38 | unzip :: [(a,b)] -> ([a],[b]) | 43 | unzip :: [(a,b)] -> ([a],[b]) |
39 | unzip [] = ([],[]) | 44 | unzip [] = ([],[]) |
@@ -41,12 +46,12 @@ unzip ((a,b):xs) = (a:as,b:bs) | |||
41 | where (as,bs) = unzip xs | 46 | where (as,bs) = unzip xs |
42 | 47 | ||
43 | filter pred [] = [] | 48 | filter pred [] = [] |
44 | filter pred (x:xs) = case (pred x) of | 49 | filter pred (x:xs) = case pred x of |
45 | True -> (x : filter pred xs) | 50 | True -> (x : filter pred xs) |
46 | False -> (filter pred xs) | 51 | False -> (filter pred xs) |
47 | 52 | ||
48 | tail :: [a] -> [a] | 53 | tail :: [a] -> [a] |
49 | tail (_ : xs) = xs | 54 | tail (_: xs) = xs |
50 | 55 | ||
51 | pairs :: [a] -> [(a, a)] | 56 | pairs :: [a] -> [(a, a)] |
52 | pairs v = zip v (tail v) | 57 | pairs v = zip v (tail v) |
@@ -83,7 +88,29 @@ sortBy f xs = uncurry (mergeBy f) ((sortBy f *** sortBy f) (split xs)) | |||
83 | data Maybe a | 88 | data Maybe a |
84 | = Nothing | 89 | = Nothing |
85 | | Just a | 90 | | Just a |
86 | deriving (Eq, Ord, Show) | 91 | -- deriving (Eq, Ord, Show) |
92 | |||
93 | |||
94 | snd (Tuple2 a b) = b | ||
95 | |||
96 | -- Row polymorphism | ||
97 | builtins | ||
98 | Split :: Type -> Type -> Type -> Type {- TODO - LATER: Constraint -} | ||
99 | |||
100 | tuptype :: List Type -> Type | ||
101 | tuptype [] = 'Tuple0 | ||
102 | tuptype (x:xs) = 'Tuple2 x (tuptype xs) | ||
103 | |||
104 | data RecordC (xs :: List (Tuple2 String Type)) | ||
105 | = RecordCons (tuptype (map snd xs)) | ||
106 | |||
107 | builtins | ||
108 | record :: List (Tuple2 String Type) -> Type | ||
109 | --record xs = RecordCons ({- TODO: sortBy fst-} xs) | ||
110 | |||
111 | builtins | ||
112 | project :: forall (xs :: List (Tuple2 String Type)) . forall (s :: String) -> Split (RecordC xs) (RecordC ('Cons ('Tuple2 s a) 'Nil)) b => RecordC xs -> a | ||
113 | |||
87 | 114 | ||
88 | --------------------------------------- HTML colors | 115 | --------------------------------------- HTML colors |
89 | 116 | ||
@@ -112,7 +139,7 @@ colorImage2 = ColorImage @2 | |||
112 | depthImage1 = DepthImage @1 | 139 | depthImage1 = DepthImage @1 |
113 | 140 | ||
114 | v3FToV4F :: Vec 3 Float -> Vec 4 Float | 141 | v3FToV4F :: Vec 3 Float -> Vec 4 Float |
115 | v3FToV4F v = V4 v%x v%y v%z 1 | 142 | v3FToV4F v = V4 0.0 0.0 0.0 1.0 --- todo! -- V4 v%x v%y v%z 1 |
116 | 143 | ||
117 | ------------ | 144 | ------------ |
118 | -- * WebGL 1 | 145 | -- * WebGL 1 |
@@ -212,6 +239,19 @@ dFdy = PrimDFdy | |||
212 | 239 | ||
213 | -- extra | 240 | -- extra |
214 | round = PrimRound | 241 | round = PrimRound |
242 | |||
243 | |||
244 | -- temp hack for vector <---> scalar operators | ||
245 | infixl 7 *!, /!, %! | ||
246 | infixl 6 +!, -! | ||
247 | |||
248 | -- arithemtic | ||
249 | a +! b = PrimAddS a b | ||
250 | a -! b = PrimSubS a b | ||
251 | a *! b = PrimMulS a b | ||
252 | a /! b = PrimDivS a b | ||
253 | a %! b = PrimModS a b | ||
254 | |||
215 | ------------------ | 255 | ------------------ |
216 | -- common matrices | 256 | -- common matrices |
217 | ------------------ | 257 | ------------------ |
@@ -264,18 +304,8 @@ lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r) | |||
264 | r = transpose $ Mat3 u v w | 304 | r = transpose $ Mat3 u v w |
265 | -} | 305 | -} |
266 | 306 | ||
267 | -- temp hack for vector <---> scalar operators | ||
268 | infixl 7 *!, /!, %! | ||
269 | infixl 6 +!, -! | ||
270 | |||
271 | -- arithemtic | ||
272 | a +! b = PrimAddS a b | ||
273 | a -! b = PrimSubS a b | ||
274 | a *! b = PrimMulS a b | ||
275 | a /! b = PrimDivS a b | ||
276 | a %! b = PrimModS a b | ||
277 | |||
278 | scale t v = v * V4 t t t 1.0 | 307 | scale t v = v * V4 t t t 1.0 |
279 | 308 | ||
280 | fromTo :: Float -> Float -> [Float] | 309 | fromTo :: Float -> Float -> [Float] |
281 | fromTo a b = if a > b then [] else a:fromTo (a +! 1.0) b | 310 | fromTo a b = if a > b then [] else a:fromTo (a +! 1.0) b |
311 | |||
diff --git a/tests/accept/PrimReduce.out b/tests/accept/PrimReduce.out index f8c7d247..f235a091 100644 --- a/tests/accept/PrimReduce.out +++ b/tests/accept/PrimReduce.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 v ;\nvoid main() {\ngl_Position = ( ( mat4 ( vec4 ( -0.9899924966004454,-0.1411200080598672,0.0,0.0 ),vec4 ( 0.1411200080598672,-0.9899924966004454,0.0,0.0 ),vec4 ( 0.0,0.0,1.0,0.0 ),vec4 ( 0.0,0.0,0.0,1.0 ) ) ) * ( v ) ) * ( vec4 ( 0.1,0.1,0.1,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,0.0,1.0,1.0 );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 1.0 0.0 0.0 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("g7",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 g7 ;\nvoid main() {\ngl_Position = ( ( mat4 ( vec4 ( cos ( 3.0 ),( 0.0 ) - ( sin ( 3.0 ) ),0.0,0.0 ),vec4 ( sin ( 3.0 ),cos ( 3.0 ),0.0,0.0 ),vec4 ( 0.0,0.0,1.0,0.0 ),vec4 ( 0.0,0.0,0.0,1.0 ) ) ) * ( g7 ) ) * ( vec4 ( 0.1,0.1,0.1,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,0.0,1.0,1.0 );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 1.0 0.0 0.0 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/prototypes/tests/accept/data.lc b/tests/accept/data.lc index 60731eb8..60731eb8 100644 --- a/prototypes/tests/accept/data.lc +++ b/tests/accept/data.lc | |||
diff --git a/prototypes/tests/accept/empty.lc b/tests/accept/empty.lc index ae71538d..ae71538d 100644 --- a/prototypes/tests/accept/empty.lc +++ b/tests/accept/empty.lc | |||
diff --git a/tests/accept/gfx02.out b/tests/accept/gfx02.out index 7d826dea..c408f1cb 100644 --- a/tests/accept/gfx02.out +++ b/tests/accept/gfx02.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("t00025",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 t00025 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00025;\ngl_Position = t00025;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("u7",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 u7 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = u7;\ngl_Position = u7;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/gfx03.out b/tests/accept/gfx03.out index ffa06c69..75f81b2e 100644 --- a/tests/accept/gfx03.out +++ b/tests/accept/gfx03.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP2",M44F)], programStreams = fromList [("t00022",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP2 ;\nin vec3 t00022 ;\nvoid main() {\ngl_Position = ( MVP2 ) * ( vec4 ( ( t00022 ).x,( t00022 ).y,( t00022 ).z,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,0.4,0.0,1.0 );\n}\n"},Program {programUniforms = fromList [("MVP2",M44F)], programStreams = fromList [("t00087",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP2 ;\nin vec3 t00087 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( ( t00087 ).x,( t00087 ).y,( t00087 ).z,1.0 );\ngl_Position = ( MVP2 ) * ( vec4 ( ( t00087 ).x,( t00087 ).y,( t00087 ).z,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) + ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00166",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 t00166 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = t00166;\ngl_Position = ( MVP ) * ( t00166 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"}], slots = [Slot {slotName = "stream", slotStreams = fromList [("position",V3F)], slotUniforms = fromList [("MVP2",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]},Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [2]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 2,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 1,SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp NoBlending (VV4B (V4 True True False False))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 20.0) NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Always False,ColorOp NoBlending (VV4B (V4 True True False False))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP2",M44F)], programStreams = fromList [("e9",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP2 ;\nin vec3 e9 ;\nvoid main() {\ngl_Position = ( MVP2 ) * ( vec4 ( 0.0,0.0,0.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,0.4,0.0,1.0 );\n}\n"},Program {programUniforms = fromList [("MVP2",M44F)], programStreams = fromList [("e23",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP2 ;\nin vec3 e23 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( 0.0,0.0,0.0,1.0 );\ngl_Position = ( MVP2 ) * ( vec4 ( 0.0,0.0,0.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) + ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("q40",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 q40 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = q40;\ngl_Position = ( MVP ) * ( q40 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"}], slots = [Slot {slotName = "stream", slotStreams = fromList [("position",V3F)], slotUniforms = fromList [("MVP2",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]},Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [2]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 2,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 1,SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp NoBlending (VV4B (V4 True True False False))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 20.0) NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Always False,ColorOp NoBlending (VV4B (V4 True True False False))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/gfx04.out b/tests/accept/gfx04.out index 30e1c9f9..ad9a997d 100644 --- a/tests/accept/gfx04.out +++ b/tests/accept/gfx04.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00022",Parameter {name = "position", ty = V3F}),("t00023",Parameter {name = "normal", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec3 t00022 ;\nin vec3 t00023 ;\nsmooth out vec4 v0 ;\nflat out vec4 v1 ;\nvoid main() {\nv0 = vec4 ( ( t00023 ).x,( t00023 ).y,( t00023 ).z,1.0 );\nv1 = vec4 ( ( t00022 ).x,( t00022 ).y,( t00022 ).z,1.0 );\ngl_Position = ( MVP ) * ( vec4 ( ( t00022 ).x,( t00022 ).y,( t00022 ).z,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nflat in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"}], slots = [Slot {slotName = "stream", slotStreams = fromList [("normal",V3F),("position",V3F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("f20",Parameter {name = "normal", ty = V3F}),("z19",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec3 z19 ;\nin vec3 f20 ;\nsmooth out vec4 v0 ;\nflat out vec4 v1 ;\nvoid main() {\nv0 = vec4 ( 0.0,0.0,0.0,1.0 );\nv1 = vec4 ( 0.0,0.0,0.0,1.0 );\ngl_Position = ( MVP ) * ( vec4 ( 0.0,0.0,0.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nflat in vec4 v1 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,1.4,1.0,0.6 ) );\n}\n"}], slots = [Slot {slotName = "stream", slotStreams = fromList [("normal",V3F),("position",V3F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/record01.out b/tests/accept/record01.out index f941f5d5..7824c8a8 100644 --- a/tests/accept/record01.out +++ b/tests/accept/record01.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00031",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 t00031 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00031;\ngl_Position = ( MVP ) * ( t00031 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,0.4,0.0,0.2 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("w12",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 w12 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = w12;\ngl_Position = ( MVP ) * ( w12 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,0.4,0.0,0.2 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/recursivetexture02.out b/tests/accept/recursivetexture02.out index 723c6e33..683cd73c 100644 --- a/tests/accept/recursivetexture02.out +++ b/tests/accept/recursivetexture02.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0}], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 0 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 1 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 2 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 3 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 4 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 5 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 6 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 7 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 8 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 9 0 Nothing)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 0.5,0.5,0.5,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( ( v0 ).x,( v0 ).y,( v0 ).x,( v0 ).y );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler4",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler4 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler4,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler3",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler3 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler3,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler2",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler2 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler2,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler1",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler1 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler1,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("u",Parameter {name = "vertexUV", ty = V2F}),("v",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler0",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v ;\nin vec2 u ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = u;\ngl_Position = ( ( MVP ) * ( v ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler0 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler0,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F),("vertexUV",V2F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1,2,3,4,5]}], streams = [], commands = [SetRenderTarget 5,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 4,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 1,SetTexture 0 9,SetSamplerUniform "sampler4" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 3,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 2,SetTexture 0 7,SetSamplerUniform "sampler3" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 2,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 3,SetTexture 0 5,SetSamplerUniform "sampler2" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 1,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 4,SetTexture 0 3,SetSamplerUniform "sampler1" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 5,SetTexture 0 1,SetSamplerUniform "sampler0" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT Red) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Depth, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0},TextureDescriptor {textureType = Texture2D (FloatT RGBA) 1, textureSize = VV2U (V2 1024 768), textureSemantic = Color, textureSampler = SamplerDescriptor {samplerWrapS = Repeat, samplerWrapT = Nothing, samplerWrapR = Nothing, samplerMinFilter = Linear, samplerMagFilter = Linear, samplerBorderColor = VV4F (V4 0.0 0.0 0.0 1.0), samplerMinLod = Nothing, samplerMaxLod = Nothing, samplerLodBias = 0.0, samplerCompareFunc = Nothing}, textureBaseLevel = 0, textureMaxLevel = 0}], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 0 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 1 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 2 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 3 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 4 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 5 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 6 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 7 0 Nothing)}]},RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (TextureImage 8 0 Nothing)},TargetItem {targetSemantic = Color, targetRef = Just (TextureImage 9 0 Nothing)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("d62",Parameter {name = "vertexUV", ty = V2F}),("w61",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 w61 ;\nin vec2 d62 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = d62;\ngl_Position = ( ( MVP ) * ( w61 ) ) * ( vec4 ( 0.5,0.5,0.5,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ).xyxy;\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("b77",Parameter {name = "position4", ty = V4F}),("i77",Parameter {name = "vertexUV", ty = V2F})], programInTextures = fromList [("sampler4",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 b77 ;\nin vec2 i77 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = i77;\ngl_Position = ( ( MVP ) * ( b77 ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler4 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler4,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("g92",Parameter {name = "position4", ty = V4F}),("n92",Parameter {name = "vertexUV", ty = V2F})], programInTextures = fromList [("sampler3",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 g92 ;\nin vec2 n92 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = n92;\ngl_Position = ( ( MVP ) * ( g92 ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler3 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler3,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("l107",Parameter {name = "position4", ty = V4F}),("s107",Parameter {name = "vertexUV", ty = V2F})], programInTextures = fromList [("sampler2",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 l107 ;\nin vec2 s107 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = s107;\ngl_Position = ( ( MVP ) * ( l107 ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler2 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler2,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("q122",Parameter {name = "position4", ty = V4F}),("x122",Parameter {name = "vertexUV", ty = V2F})], programInTextures = fromList [("sampler1",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 q122 ;\nin vec2 x122 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = x122;\ngl_Position = ( ( MVP ) * ( q122 ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler1 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler1,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"},Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("c138",Parameter {name = "vertexUV", ty = V2F}),("v137",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [("sampler0",FTexture2D)], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 v137 ;\nin vec2 c138 ;\nsmooth out vec2 v0 ;\nvoid main() {\nv0 = c138;\ngl_Position = ( ( MVP ) * ( v137 ) ) * ( vec4 ( 1.0,1.0,1.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform sampler2D sampler0 ;\nsmooth in vec2 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( texture2D ( sampler0,v0 ) ) * ( vec4 ( 0.7,0.7,0.7,1.0 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F),("vertexUV",V2F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1,2,3,4,5]}], streams = [], commands = [SetRenderTarget 5,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 4,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 1,SetTexture 0 9,SetSamplerUniform "sampler4" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 3,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 2,SetTexture 0 7,SetSamplerUniform "sampler3" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 2,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 3,SetTexture 0 5,SetSamplerUniform "sampler2" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 1,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 4,SetTexture 0 3,SetSamplerUniform "sampler1" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.0 1.0)}],SetProgram 5,SetTexture 0 1,SetSamplerUniform "sampler0" 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/reduce01.out b/tests/accept/reduce01.out index fe31a70c..c408f1cb 100644 --- a/tests/accept/reduce01.out +++ b/tests/accept/reduce01.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [(Color,Just (Framebuffer Color))]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("t00027",("position4",V4F))], programInTextures = fromList [], programOutput = [("f0",V4F)], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 t00027 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00027;\ngl_Position = t00027;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [(Color,VV4F (V4 0.0 0.0 0.4 1.0))],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("u7",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 u7 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = u7;\ngl_Position = u7;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/reduce05.out b/tests/accept/reduce05.out index 2d50fe02..6085a9c8 100644 --- a/tests/accept/reduce05.out +++ b/tests/accept/reduce05.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("t00020",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 t00020 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00020;\ngl_Position = t00020;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 1.0,0.0,0.0,1.0 );\n}\n"},Program {programUniforms = fromList [], programStreams = fromList [("t00020",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 t00020 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00020;\ngl_Position = t00020;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,1.0,0.0,1.0 );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0,1]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 1.0 1.0)}],SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 False True False False))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True False False False))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("f8",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 f8 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = f8;\ngl_Position = f8;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 1.0,0.0,0.0,1.0 );\n}\n"},Program {programUniforms = fromList [], programStreams = fromList [("q18",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 q18 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = q18;\ngl_Position = q18;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 0.0,1.0,0.0,1.0 );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Triangles, slotPrograms = [0,1]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 1.0 1.0)}],SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 False True False False))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True False False False))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/reduce06.out b/tests/accept/reduce06.out index 4791ed55..0faab023 100644 --- a/tests/accept/reduce06.out +++ b/tests/accept/reduce06.out | |||
@@ -1 +1 @@ | |||
True \ No newline at end of file | Exp (Con_ ("True",Exp (Con_ ("Bool",Exp TType_) [])) []) \ No newline at end of file | ||
diff --git a/tests/accept/simple02.out b/tests/accept/simple02.out index f941f5d5..7824c8a8 100644 --- a/tests/accept/simple02.out +++ b/tests/accept/simple02.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00031",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 t00031 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = t00031;\ngl_Position = ( MVP ) * ( t00031 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,0.4,0.0,0.2 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("w12",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 w12 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = w12;\ngl_Position = ( MVP ) * ( w12 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = ( v0 ) * ( vec4 ( 1.0,0.4,0.0,0.2 ) );\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Triangles, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp (Blend {colorEqSrc = FuncAdd, alphaEqSrc = FuncAdd, colorFSrc = SrcAlpha, colorFDst = OneMinusSrcAlpha, alphaFSrc = SrcAlpha, alphaFDst = OneMinusSrcAlpha, color = V4 1.0 1.0 1.0 1.0}) (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/simple03.out b/tests/accept/simple03.out index 2568ce50..3a065c2c 100644 --- a/tests/accept/simple03.out +++ b/tests/accept/simple03.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("viewProj",M44F)], programStreams = fromList [("t00028",Parameter {name = "position", ty = V3F}),("t00029",Parameter {name = "color", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nin vec3 t00028 ;\nin vec3 t00029 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( ( t00029 ).x,( t00029 ).y,( t00029 ).z,1.0 );\ngl_Position = ( viewProj ) * ( vec4 ( ( t00028 ).x,( t00028 ).y,( t00028 ).z,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 1.0,1.0,1.0,1.0 );\n}\n"},Program {programUniforms = fromList [("viewProj",M44F)], programStreams = fromList [("t00088",Parameter {name = "position", ty = V3F}),("t00089",Parameter {name = "color", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nin vec3 t00088 ;\nin vec3 t00089 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( ( t00089 ).x,( t00089 ).y,( t00089 ).z,1.0 );\ngl_Position = ( viewProj ) * ( vec4 ( ( t00088 ).x,( t00088 ).y,( t00088 ).z,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "missing shader", slotStreams = fromList [("color",V3F),("position",V3F)], slotUniforms = fromList [("viewProj",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.4 1.0)}],SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 20.0) (Offset (-1.0) 0.0) FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)},TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("viewProj",M44F)], programStreams = fromList [("b13",Parameter {name = "color", ty = V3F}),("v12",Parameter {name = "position", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nin vec3 v12 ;\nin vec3 b13 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( 0.0,0.0,0.0,1.0 );\ngl_Position = ( viewProj ) * ( vec4 ( 0.0,0.0,0.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = vec4 ( 1.0,1.0,1.0,1.0 );\n}\n"},Program {programUniforms = fromList [("viewProj",M44F)], programStreams = fromList [("c31",Parameter {name = "position", ty = V3F}),("i31",Parameter {name = "color", ty = V3F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 viewProj ;\nin vec3 c31 ;\nin vec3 i31 ;\nsmooth out vec4 v0 ;\nvoid main() {\nv0 = vec4 ( 0.0,0.0,0.0,1.0 );\ngl_Position = ( viewProj ) * ( vec4 ( 0.0,0.0,0.0,1.0 ) );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nsmooth in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "missing shader", slotStreams = fromList [("color",V3F),("position",V3F)], slotUniforms = fromList [("viewProj",M44F)], slotPrimitive = Triangles, slotPrograms = [0,1]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0},ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.0 0.0 0.4 1.0)}],SetProgram 1,SetRasterContext (TriangleCtx CullNone PolygonFill NoOffset FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0,SetProgram 0,SetRasterContext (TriangleCtx CullNone (PolygonLine 20.0) (Offset (-1.0) 0.0) FirstVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Lequal True,ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/swizzling.out b/tests/accept/swizzling.out index 4791ed55..0faab023 100644 --- a/tests/accept/swizzling.out +++ b/tests/accept/swizzling.out | |||
@@ -1 +1 @@ | |||
True \ No newline at end of file | Exp (Con_ ("True",Exp (Con_ ("Bool",Exp TType_) [])) []) \ No newline at end of file | ||
diff --git a/tests/accept/recursivetexture01.lc b/tests/accept/tmp/recursivetexture01.lc index 681894b9..681894b9 100644 --- a/tests/accept/recursivetexture01.lc +++ b/tests/accept/tmp/recursivetexture01.lc | |||
diff --git a/tests/accept/uniformparam01.out b/tests/accept/uniformparam01.out index 7cb89db0..1554cccc 100644 --- a/tests/accept/uniformparam01.out +++ b/tests/accept/uniformparam01.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00027",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 t00027 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = t00027;\ngl_Position = ( MVP ) * ( t00027 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("s7",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 s7 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = s7;\ngl_Position = ( MVP ) * ( s7 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/uniformparam02.out b/tests/accept/uniformparam02.out index 66801067..efe3326a 100644 --- a/tests/accept/uniformparam02.out +++ b/tests/accept/uniformparam02.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("t00012",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 t00012 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = t00012;\ngl_Position = t00012;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nvoid main() {\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0}],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Depth, targetRef = Just (Framebuffer Depth)}]}], programs = [Program {programUniforms = fromList [], programStreams = fromList [("v4",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nin vec4 v4 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = v4;\ngl_Position = v4;\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nvoid main() {\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Depth, clearValue = VFloat 1000.0}],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [DepthOp Less False]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/uniformparam03.out b/tests/accept/uniformparam03.out index 0f8a775e..1554cccc 100644 --- a/tests/accept/uniformparam03.out +++ b/tests/accept/uniformparam03.out | |||
@@ -1 +1 @@ | |||
Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [(Color,Just (Framebuffer Color))]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("t00027",("position4",V4F))], programInTextures = fromList [], programOutput = [("f0",V4F)], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 t00027 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = t00027;\ngl_Position = ( MVP ) * ( t00027 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [(Color,VV4F (V4 0.5 0.0 0.4 1.0))],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | Pipeline {backend = OpenGL33, textures = [], samplers = [], targets = [RenderTarget {renderTargets = [TargetItem {targetSemantic = Color, targetRef = Just (Framebuffer Color)}]}], programs = [Program {programUniforms = fromList [("MVP",M44F)], programStreams = fromList [("s7",Parameter {name = "position4", ty = V4F})], programInTextures = fromList [], programOutput = [Parameter {name = "f0", ty = V4F}], vertexShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nuniform mat4 MVP ;\nin vec4 s7 ;\nflat out vec4 v0 ;\nvoid main() {\nv0 = s7;\ngl_Position = ( MVP ) * ( s7 );\ngl_PointSize = 1.0;\n}\n", geometryShader = Nothing, fragmentShader = "#version 330 core\nvec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}\nflat in vec4 v0 ;\nout vec4 f0 ;\nvoid main() {\nf0 = v0;\n}\n"}], slots = [Slot {slotName = "stream4", slotStreams = fromList [("position4",V4F)], slotUniforms = fromList [("MVP",M44F)], slotPrimitive = Lines, slotPrograms = [0]}], streams = [], commands = [SetRenderTarget 0,ClearRenderTarget [ClearImage {imageSemantic = Color, clearValue = VV4F (V4 0.5 0.0 0.4 1.0)}],SetProgram 0,SetRasterContext (LineCtx 1.0 LastVertex),SetAccumulationContext (AccumulationContext {accViewportName = Nothing, accOperations = [ColorOp NoBlending (VV4B (V4 True True True True))]}),RenderSlot 0]} \ No newline at end of file | ||
diff --git a/tests/accept/where.lc b/tests/accept/where.lc new file mode 100644 index 00000000..bf9db0f2 --- /dev/null +++ b/tests/accept/where.lc | |||
@@ -0,0 +1,8 @@ | |||
1 | {-# LANGUAGE NoImplicitPrelude #-} | ||
2 | |||
3 | f = x | ||
4 | where | ||
5 | z = y | ||
6 | where | ||
7 | y = 1.0 | ||
8 | x = 1.0 | ||
diff --git a/tests/demo/fragmenttest.lc b/tests/demo/tmp/fragmenttest.lc index 47ef3ebe..47ef3ebe 100644 --- a/tests/demo/fragmenttest.lc +++ b/tests/demo/tmp/fragmenttest.lc | |||
diff --git a/prototypes/tests/reject/data.lc b/tests/reject/data.lc index 4f609a33..4f609a33 100644 --- a/prototypes/tests/reject/data.lc +++ b/tests/reject/data.lc | |||
diff --git a/prototypes/tests/reject/empty.lc b/tests/reject/empty.lc index 5349cc9b..5349cc9b 100644 --- a/prototypes/tests/reject/empty.lc +++ b/tests/reject/empty.lc | |||
diff --git a/tests/reject/accumulate01.lc b/tests/rejectold/accumulate01.lc index 7b0e20da..7b0e20da 100644 --- a/tests/reject/accumulate01.lc +++ b/tests/rejectold/accumulate01.lc | |||
diff --git a/tests/reject/accumulate02.lc b/tests/rejectold/accumulate02.lc index 3c4767c2..3c4767c2 100644 --- a/tests/reject/accumulate02.lc +++ b/tests/rejectold/accumulate02.lc | |||
diff --git a/tests/reject/accumulate03.lc b/tests/rejectold/accumulate03.lc index fa0a8fba..fa0a8fba 100644 --- a/tests/reject/accumulate03.lc +++ b/tests/rejectold/accumulate03.lc | |||
diff --git a/tests/reject/adhoc.lc b/tests/rejectold/adhoc.lc index 42e2d968..42e2d968 100644 --- a/tests/reject/adhoc.lc +++ b/tests/rejectold/adhoc.lc | |||
diff --git a/tests/reject/fragctx01.lc b/tests/rejectold/fragctx01.lc index 9edefca9..9edefca9 100644 --- a/tests/reject/fragctx01.lc +++ b/tests/rejectold/fragctx01.lc | |||
diff --git a/tests/reject/fragctx02.lc b/tests/rejectold/fragctx02.lc index 375b943f..375b943f 100644 --- a/tests/reject/fragctx02.lc +++ b/tests/rejectold/fragctx02.lc | |||
diff --git a/tests/reject/framebuffer01.lc b/tests/rejectold/framebuffer01.lc index f39b24ff..f39b24ff 100644 --- a/tests/reject/framebuffer01.lc +++ b/tests/rejectold/framebuffer01.lc | |||
diff --git a/tests/reject/framebuffer02.lc b/tests/rejectold/framebuffer02.lc index ab8504f6..ab8504f6 100644 --- a/tests/reject/framebuffer02.lc +++ b/tests/rejectold/framebuffer02.lc | |||
diff --git a/tests/reject/framebuffer03.lc b/tests/rejectold/framebuffer03.lc index 0cbfc28a..0cbfc28a 100644 --- a/tests/reject/framebuffer03.lc +++ b/tests/rejectold/framebuffer03.lc | |||
diff --git a/tests/reject/instantiate.lc b/tests/rejectold/instantiate.lc index 4e3bcfbb..4e3bcfbb 100644 --- a/tests/reject/instantiate.lc +++ b/tests/rejectold/instantiate.lc | |||
diff --git a/tests/reject/listcompr01.lc b/tests/rejectold/listcompr01.lc index 37d01261..37d01261 100644 --- a/tests/reject/listcompr01.lc +++ b/tests/rejectold/listcompr01.lc | |||
diff --git a/tests/reject/nameclash01.lc b/tests/rejectold/nameclash01.lc index 18776b15..18776b15 100644 --- a/tests/reject/nameclash01.lc +++ b/tests/rejectold/nameclash01.lc | |||
diff --git a/tests/reject/rastctx01.lc b/tests/rejectold/rastctx01.lc index 2a667319..2a667319 100644 --- a/tests/reject/rastctx01.lc +++ b/tests/rejectold/rastctx01.lc | |||
diff --git a/tests/reject/record01.lc b/tests/rejectold/record01.lc index 994a55a4..994a55a4 100644 --- a/tests/reject/record01.lc +++ b/tests/rejectold/record01.lc | |||
diff --git a/tests/reject/scope01.lc b/tests/rejectold/scope01.lc index 336afac7..336afac7 100644 --- a/tests/reject/scope01.lc +++ b/tests/rejectold/scope01.lc | |||
diff --git a/tests/reject/syntax01.lc b/tests/rejectold/syntax01.lc index 87505f14..87505f14 100644 --- a/tests/reject/syntax01.lc +++ b/tests/rejectold/syntax01.lc | |||
diff --git a/tests/reject/syntax02.lc b/tests/rejectold/syntax02.lc index 868168a9..868168a9 100644 --- a/tests/reject/syntax02.lc +++ b/tests/rejectold/syntax02.lc | |||
diff --git a/tests/rejectold/typesig.lc b/tests/rejectold/typesig.lc new file mode 100644 index 00000000..4c00d33a --- /dev/null +++ b/tests/rejectold/typesig.lc | |||
@@ -0,0 +1,8 @@ | |||
1 | {-# LANGUAGE NoImplicitPrelude #-} | ||
2 | |||
3 | data X = X | ||
4 | |||
5 | x :: x | ||
6 | x = X | ||
7 | |||
8 | |||
diff --git a/tests/reject/typesigctx.lc b/tests/rejectold/typesigctx.lc index 0c5f00fe..0c5f00fe 100644 --- a/tests/reject/typesigctx.lc +++ b/tests/rejectold/typesigctx.lc | |||