packages feed

glsl (empty) → 0.0.0.1

raw patch · 21 files changed

+2029/−0 lines, 21 filesdep +attoparsecdep +basedep +bytestring

Dependencies added: attoparsec, base, bytestring, containers, fgl, glsl, graphviz, hspec, lens, linear, scientific, text, time, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+### 0.0.0.1++- Initial release. Comes with parser and interpreter. Optimizer not done yet.
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (c) 2021, Pippijn van Steenhoven+ All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are +permitted provided that the following conditions are met:++Redistributions of source code must retain the above copyright notice, this list of +conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright notice, this list of +conditions and the following disclaimer in the documentation and/or other materials +provided with the distribution.++Neither the name of Mark Peter Wassell nor the names of its contributors may be used +to endorse or promote products derived from this software without specific prior written +permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ glsl.cabal view
@@ -0,0 +1,93 @@+name:           glsl+version:        0.0.0.1+cabal-version:  >= 1.10+build-type:     Simple+author:         Pippijn van Steenhoven+license:        BSD3+license-file:   LICENSE+copyright:      2021 Pippijn van Steenhoven+category:       Graphics+stability:      Experimental+homepage:       https://github.com/homectl/glsl+synopsis:       Parser and optimizer for a small subset of GLSL+description:+                Parser and optimizer for a small subset of GLSL.++                This package can parse a very small subset of GLSL, namely+                exactly the subset emitted by GPipe-Core. It can evaluate the+                code and return the computed result. This is useful for+                debugging shaders generated by GPipe-Core.+maintainer:     Pippijn van Steenhoven+data-files:     CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/homectl/workspace+  subdir:   glsl++library+  default-language: Haskell2010+  hs-source-dirs: src+  exposed-modules:+      Language.GLSL.ConstExpr+      Language.GLSL.Decls+      Language.GLSL.Optimizer.Deinline+      Language.GLSL.Optimizer.DFG+      Language.GLSL.Optimizer.FunctionGenerator+      Language.GLSL.Optimizer.Liveness+      Language.GLSL.Optimizer+      Language.GLSL.Runtime.Eval+      Language.GLSL.Runtime.Math+      Language.GLSL.Runtime.PrimFuns+      Language.GLSL.Runtime.Value+      Language.GLSL.StructuralEquality+      Language.GLSL.Types+  build-depends:+      base                          >= 4.9 && < 5+    , attoparsec                    >= 0.10 && < 0.15+    , containers                    >= 0.5 && < 0.7+    , fgl                           >= 5.3 && < 6+    , graphviz                      >= 2999.10 && < 2999.21+    , lens                          >= 4.15.2 && < 6+    , linear                        >= 1.18 && < 1.22+    , scientific                    >= 0.3.1 && < 0.4+    , text                          >= 0.10 && < 1.3+    , transformers                  >= 0.5.2 && < 0.6+  ghc-options:+      -Wall++test-suite testsuite+  default-language: Haskell2010+  hs-source-dirs:   test+  type: exitcode-stdio-1.0+  main-is:          testsuite.hs+  other-modules:+      Language.GLSL.Optimizer.DeinlineSpec+      Language.GLSL.GLSLSpec+      Test.GLSL+  ghc-options:+      -Wall+      -threaded+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base+    , attoparsec+    , bytestring+    , glsl+    , hspec+    , text++executable optshader+  default-language: Haskell2010+  hs-source-dirs:   tools+  main-is:          optshader.hs+  ghc-options:+      -Wall+      -rtsopts+      -threaded+  build-depends:+      base < 5+    , glsl+    , text+    , time
+ src/Language/GLSL/ConstExpr.hs view
@@ -0,0 +1,45 @@+module Language.GLSL.ConstExpr+  ( ConstExprs+  , collectConstExprs+  , isConstExpr+  ) where++import qualified Data.IntSet         as S+import           Language.GLSL.Types+++newtype ConstExprs = ConstExprs S.IntSet++collectConstExprs :: [StmtAnnot a] -> ConstExprs+collectConstExprs = ConstExprs . foldr (add . unAnnot) S.empty+  where+    add :: Stmt a -> S.IntSet -> S.IntSet+    add (AssignStmt (Name NsT (NameId n)) e) s+      | isConstExpr (ConstExprs s) e = S.insert n s+    add _ s = s+++isConstExpr :: ConstExprs -> Expr -> Bool+isConstExpr ce (BinaryExpr l BOpMul r) =+  any isZero [l, r] || all (isConstExprAtom ce) [l, r]++isConstExpr ce (AtomExpr e)         = isConstExprAtom ce e+isConstExpr ce (UnaryExpr _ e)      = isConstExprAtom ce e+isConstExpr ce (BinaryExpr l _ r)   = all (isConstExprAtom ce) [l, r]+isConstExpr ce (FunCallExpr _ args) = all (isConstExprAtom ce) args+isConstExpr _ TextureExpr{}         = False+++isConstExprAtom :: ConstExprs -> ExprAtom -> Bool+isConstExprAtom (ConstExprs ce) (IdentifierExpr (NameExpr (Name NsT (NameId n)))) =+  S.member n ce++isConstExprAtom _ LitIntExpr{}   = True+isConstExprAtom _ LitFloatExpr{} = True+isConstExprAtom _ _              = False+++isZero :: ExprAtom -> Bool+isZero (LitIntExpr _ 0)   = True+isZero (LitFloatExpr _ 0) = True+isZero _                  = False
+ src/Language/GLSL/Decls.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData      #-}+module Language.GLSL.Decls where++import qualified Data.IntMap.Strict  as M+import           Language.GLSL.Types (Name (..), NameExpr (..), NameId (..),+                                      Namespace (..))+++data Decls a = Decls+  { declsS   :: M.IntMap a+  , declsT   :: M.IntMap a+  , declsU   :: M.IntMap a+  , declsVF  :: M.IntMap a+  , declsIn  :: M.IntMap a+  , declsOut :: M.IntMap a+  }++emptyDecls :: Decls a+emptyDecls = Decls M.empty M.empty M.empty M.empty M.empty M.empty++addDecl :: Namespace -> NameId -> a -> Decls a -> Decls a+addDecl NsT (NameId n) v decls@Decls{..} = decls{declsT = M.insert n v declsT}+addDecl NsS (NameId n) v decls@Decls{..} = decls{declsS = M.insert n v declsS}+addDecl NsU (NameId n) v decls@Decls{..} = decls{declsU = M.insert n v declsU}+addDecl NsVF (NameId n) v decls@Decls{..} = decls{declsVF = M.insert n v declsVF}+addDecl NsIn (NameId n) v decls@Decls{..} = decls{declsIn = M.insert n v declsIn}+addDecl NsOut (NameId n) v decls@Decls{..} = decls{declsOut = M.insert n v declsOut}++addDeclN :: Name -> a -> Decls a -> Decls a+addDeclN (Name ns n) = addDecl ns n++addDeclNE :: NameExpr -> a -> Decls a -> Decls a+addDeclNE (NameExpr n)      = addDeclN n+addDeclNE (UniformExpr n m) = addDecl NsU (toUniformId (n, m))++getDecls :: Namespace -> Decls a -> M.IntMap a+getDecls NsT Decls{..}   = declsT+getDecls NsS Decls{..}   = declsS+getDecls NsU Decls{..}   = declsU+getDecls NsVF Decls{..}  = declsVF+getDecls NsIn Decls{..}  = declsIn+getDecls NsOut Decls{..} = declsOut++getDecl :: Namespace -> NameId -> Decls a -> Maybe a+getDecl ns (NameId n) decls = M.lookup n (getDecls ns decls)++getDeclN :: Name -> Decls a -> Maybe a+getDeclN (Name ns n) = getDecl ns n++getDeclNE :: NameExpr -> Decls a -> Maybe a+getDeclNE (NameExpr n)      = getDeclN n+getDeclNE (UniformExpr n m) = getDecl NsU (toUniformId (n, m))++toUniformId :: (NameId, NameId) -> NameId+toUniformId (NameId n, NameId m) = NameId $ n * 1000 + m++fromUniformId :: NameId -> (NameId, NameId)+fromUniformId (NameId i) = let (n, m) = i `divMod` 1000 in (NameId n, NameId m)++showUniformId :: NameId -> String+showUniformId i =+  let (n, m) = fromUniformId i in+  "u" <> show n <> ".u" <> show m
+ src/Language/GLSL/Optimizer.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData        #-}+module Language.GLSL.Optimizer where++import           Control.Monad                    (when)+import           Data.Attoparsec.ByteString.Char8 (Parser)+import qualified Data.Text.Lazy                   as LT+import qualified Data.Text.Lazy.IO                as IO+import qualified Language.GLSL.Optimizer.Deinline as Deinline+import qualified Language.GLSL.Optimizer.Liveness as Liveness+import           Language.GLSL.Types              (Annot, GLSL, parseGLSL,+                                                   parseShader, parseTest,+                                                   printShader)+++optimizeShader :: LT.Text -> Either String LT.Text+-- optimizeShader = fmap printShader . parse+optimizeShader = fmap (printShader . optimize) . parse+++parse :: LT.Text -> Either String (GLSL ())+parse = parseShader++optimize :: Annot a => GLSL a -> GLSL a+optimize = (`const` id)+  -- . foldr (.) id (replicate 20 $ Deinline.pass Deinline.defaultConfig{Deinline.windowSize=5})+  -- . foldr (.) id (replicate 30 $ Deinline.pass Deinline.defaultConfig{Deinline.windowSize=10})+  . Deinline.pass Deinline.defaultConfig{Deinline.windowSize=10}+++main :: IO ()+main = do+  putStrLn "Loading shader source..."+  -- inText <- IO.readFile "../large-shaders/lambdacnc.frag"+  -- inText <- IO.readFile "../large-shaders/lambdacnc.vert"+  -- inText <- IO.readFile "../large-shaders/lambdaray.frag"+  -- inText <- IO.readFile "../large-shaders/xax.frag"+  inText <- IO.readFile "../large-shaders/xax.vert"+  -- inText <- IO.readFile "../large-shaders/small.vert"+  when False $ parseTest (parseGLSL :: Parser (GLSL ())) inText+  putStrLn "Parsing shader source..."+  case parse inText of+    Left err -> writeFile "../opt.glsl" $ "// Error\n" <> err+    Right ok -> do+      putStrLn "Computing liveness..."+      let ls = Liveness.computeLiveness ok+      putStrLn "Optimizing shader..."+      IO.writeFile "../opt.glsl" $ printShader $ optimize ls
+ src/Language/GLSL/Optimizer/DFG.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE NamedFieldPuns  #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData      #-}+module Language.GLSL.Optimizer.DFG where++import           Control.Monad.Trans.State (StateT, execState, get, modify',+                                            put)+import           Data.Foldable             (forM_)+import           Data.Functor              (void)+import           Data.Functor.Identity     (Identity)+import           Data.Graph.Inductive      (Node)+import qualified Data.Graph.Inductive      as G+import qualified Data.GraphViz             as GV+import qualified Data.GraphViz.Printing    as GV+import qualified Data.Text.Lazy.IO         as IO+import           Language.GLSL.Decls+import           Language.GLSL.Types       hiding (t)++--------------------------------------------------------------------------------++data DFG = DFG+  { gr         :: G.Gr DFGNode DFGEdge+  , decls      :: Decls Node+  , nextNodeId :: Node+  , ifCond     :: Maybe Node+  }++emptyDFG :: DFG+emptyDFG = DFG+  { gr = G.empty+  , decls = emptyDecls+  , nextNodeId = 0+  , ifCond = Nothing+  }++data DFGEdge = DFGEdge+  deriving (Show)++data DFGNode+  = DFGNode Namespace NameId+  deriving (Show)++type DFGState = StateT DFG Identity++genDFG :: GLSL a -> DFG+genDFG prog = execState (dfgGLSL prog) emptyDFG++dfgGLSL :: GLSL a -> DFGState ()+dfgGLSL (GLSL _ decls) = mapM_ dfgTopDecl decls++dfgTopDecl :: TopDecl a -> DFGState ()+dfgTopDecl (LayoutDecl _ d)     = dfgGlobalDecl d+dfgTopDecl (GlobalDecl d)       = dfgGlobalDecl d+dfgTopDecl (ProcDecl _ _ stmts) = mapM_ dfgStmtAnnot stmts++dfgGlobalDecl :: GlobalDecl -> DFGState ()+dfgGlobalDecl (GDecl _ (TyStruct _ ms) (Name NsU n)) =+  mapM_ (dfgStructMember n) ms+dfgGlobalDecl (GDecl _ _ (Name ns n)) =+  void $ addNode ns n++dfgStructMember :: NameId -> (Type, NameId) -> DFGState ()+dfgStructMember n (_, m) = void $ addNode NsU (toUniformId (n, m))++dfgStmt :: Stmt a -> DFGState ()+dfgStmt (DeclStmt d)     = dfgLocalDecl d+dfgStmt (AssignStmt n e) = do+  targetId <- nodeForName n+  DFG{ifCond} <- get+  forM_ ifCond (addEdge targetId)+  dfgExpr e targetId+dfgStmt (IfStmt c t e) = do+  ifCond <- Just <$> nodeFor NsT c+  modify' $ \dfg -> dfg{ifCond}+  mapM_ dfgStmtAnnot (t ++ e)+  modify' $ \dfg -> dfg{ifCond=Nothing}+dfgStmt _                = return ()++dfgStmtAnnot :: StmtAnnot a -> DFGState ()+dfgStmtAnnot (SA _ s) = dfgStmt s++dfgLocalDecl :: LocalDecl -> DFGState ()+dfgLocalDecl (LDecl _ n e) = do+  nodeId <- addNode NsT n+  maybe (return ()) (`dfgExpr` nodeId) e++dfgExpr :: Expr -> Node -> DFGState ()+dfgExpr (FunCallExpr _ args) declNode = mapM_ (`dfgExprAtom` declNode) args+dfgExpr (TextureExpr t x y) declNode  = mapM_ (`dfgExprAtom` declNode) [t, x, y]+dfgExpr (UnaryExpr _ e) declNode      = dfgExprAtom e declNode+dfgExpr (AtomExpr e) declNode         = dfgExprAtom e declNode+dfgExpr (BinaryExpr l _ r) declNode   = mapM_ (`dfgExprAtom` declNode) [l, r]++dfgExprAtom :: ExprAtom -> Node -> DFGState ()+dfgExprAtom LitIntExpr{} _                = return ()+dfgExprAtom LitFloatExpr{} _              = return ()+dfgExprAtom (IdentifierExpr n) declNode   = nodeForNameExpr n >>= addEdge declNode+dfgExprAtom (SwizzleExpr n _)  declNode   = nodeFor NsT n >>= addEdge declNode+dfgExprAtom (VecIndexExpr n _) declNode   = nodeForNameExpr n >>= addEdge declNode+dfgExprAtom (MatIndexExpr n _ _) declNode = nodeForNameExpr n >>= addEdge declNode+++nodeForUniform :: NameId -> NameId -> DFGState Node+nodeForUniform n m = do+  DFG{..} <- get+  let i = toUniformId (n, m)+  case getDecl NsU i decls of+    Nothing -> error $ "no node for " <> showUniformId i+    Just ok -> return ok++nodeForNameExpr :: NameExpr -> DFGState Node+nodeForNameExpr (NameExpr n)      = nodeForName n+nodeForNameExpr (UniformExpr n m) = nodeForUniform n m++nodeForName :: Name -> DFGState Node+nodeForName (Name ns n) = nodeFor ns n++nodeFor :: Namespace -> NameId -> DFGState Node+nodeFor ns n = do+  DFG{..} <- get+  case getDecl ns n decls of+    Nothing -> error $ "no node for " <> pp ppName (Name ns n)+    Just ok -> return ok++addEdge :: Node -> Node -> DFGState ()+addEdge declNode idNode =+  modify' $ \g@DFG{gr} -> g { gr = G.insEdge (declNode, idNode, DFGEdge) gr }++addNode :: Namespace -> NameId -> DFGState Node+addNode ns n = do+  g@DFG{..} <- get+  let nodeId = nextNodeId+  put g { gr = G.insNode (nodeId, DFGNode ns n) gr+        , decls = addDecl ns n nodeId decls+        , nextNodeId = nextNodeId + 1+        }+  return nodeId++--------------------------------------------------------------------------------+-- Visualisation+--------------------------------------------------------------------------------++instance GV.Labellable DFGNode where+  toLabelValue (DFGNode NsU i) = GV.toLabelValue $ showUniformId i+  toLabelValue (DFGNode ns n) = GV.toLabelValue $+    pp ppNamespace ns <> show n++instance GV.Labellable DFGEdge where+  toLabelValue DFGEdge = GV.toLabelValue ""++toDot :: FilePath -> DFG -> IO ()+toDot path =+  IO.writeFile path . GV.printIt . GV.graphToDot GV.quickParams . gr++toSvg :: DFG -> FilePath -> IO FilePath+toSvg DFG{gr} = GV.runGraphviz (GV.graphToDot GV.quickParams gr) GV.Svg
+ src/Language/GLSL/Optimizer/Deinline.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections   #-}+module Language.GLSL.Optimizer.Deinline where++import           Control.Applicative                       (ZipList (..))+import           Control.Arrow                             ((&&&))+import qualified Data.List                                 as List+import           Data.Maybe                                (listToMaybe)+import           Debug.Trace                               (trace)+import           Language.GLSL.ConstExpr                   (ConstExprs,+                                                            collectConstExprs)+import qualified Language.GLSL.Optimizer.FunctionGenerator as FunctionGenerator+import qualified Language.GLSL.StructuralEquality          as StructuralEquality+import           Language.GLSL.Types+++data Config = Config+  { maxLookahead :: Int+  -- ^ Maximum number of statements to look ahead for equality.+  --+  --   Increasing this potentially finds more de-inlining opportunities but also+  --   drastically increases the cost of not finding any. This number does not+  --   matter if we always find an opportunity quickly.++  , minRepeats   :: Int+  -- ^ Minimum number of times a piece of code needs to appear for it to be+  --   worth extracting into a function.++  , maxRepeats   :: Int+  -- ^ Maximum number of initial repeats to use for maximization. If we find+  --   enough, we're happy and stop looking. Most of the time we'll find fewer+  --   than 10, but sometimes a bit of code is repeated a lot which would slow+  --   down the algorithm significantly.++  , windowSize   :: Int+  -- ^ Number of statements in the sliding window.+  }+++defaultConfig :: Config+defaultConfig = Config+  { maxLookahead = 200+  , minRepeats = 3+  , maxRepeats = 10+  , windowSize = 10+  }+++pass :: Annot a => Config -> GLSL a -> GLSL a+pass config (GLSL v d) = GLSL v (map (diTopDecl config) d)++diTopDecl :: Annot a => Config -> TopDecl a -> TopDecl a+diTopDecl config (ProcDecl fn params body) =+  ProcDecl fn params $ diStmts config body+diTopDecl _ d = d+++diStmts :: Annot a => Config -> [StmtAnnot a] -> [StmtAnnot a]+diStmts config ss =+  let ce = collectConstExprs ss in+  case findBody config ce ss of+    Nothing -> ss+    Just body ->+      let _newProc = pp ppTopDecl (FunctionGenerator.makeFunction body) in+      trace (+        "found one! length = " <> show (length body)+        -- <> "\n" <> ppl ppStmtAnnot body <> "\n\n"+        -- <> newProc+      ) $ deleteBody ce body ss+++-- | Remove all occurrences of 'body' from 'ss'.+deleteBody :: ConstExprs -> [StmtAnnot a] -> [StmtAnnot a] -> [StmtAnnot a]+deleteBody ce body = go []+  where+    go acc [] = reverse acc+    go acc (s:ss) =+      if StructuralEquality.eqStmtAnnots ce (zip body ss)+        then go (s:acc) (drop (length body) ss)+        else go (s:acc) ss+++findBody :: Config -> ConstExprs -> [StmtAnnot a] -> Maybe [StmtAnnot a]+findBody _ _ [] = Nothing+findBody Config{..} _ (_:ss) | length ss < windowSize = Nothing+findBody config@Config{..} ce (_:ss) =+  let+    -- Get a peep hole window of statements.+    window = take windowSize ss++    -- We'll iterate over all possible sub-programs from the current position.+    tails = List.tails ss++    -- We want to find similar statements and filter out the empty sub-program+    -- since the empty list is trivially equal to another empty list.+    isSimilar l = not (null l) && StructuralEquality.eqStmtAnnots ce l++    -- Try to find a similar set of statements to the window somewhere in the+    -- lookahead range.+    firstRepeat =+      List.find isSimilar+      . map (zip window)+      . take maxLookahead+      $ tails++    -- If we found one, see how many more we find in the code.+    --+    -- If we find enough, we're happy and stop looking. Most of the time we'll+    -- find fewer than 10, but sometimes a bit of code is repeated a lot which would+    -- slow down the algorithm.+    allRepeats =+      take maxRepeats+      . map fst+      . filter (isSimilar . snd)+      . map (id &&& zip window)+      $ tails++    -- If there are enough repeats to be worth extracting, try to maximise+    -- the amount of code extracted.+    maximised =+      transpose+      . takeWhile (allEqual ce)+      . transpose+      $ ss : allRepeats+  in+  case firstRepeat of+    -- No matches, continue looking.+    Nothing -> findBody config ce ss+    -- Found one, but the number of repeats doesn't make it worth+    -- extracting into a function (minRepeats counts the first occurrence+    -- which is in the window and not in allRepeats).+    Just _ | length (take (minRepeats - 1) allRepeats) < minRepeats - 1 ->+      findBody config ce ss+    -- Found one with several repeats, we'll extract this one.+    Just _ -> listToMaybe maximised+++transpose :: [[a]] -> [[a]]+transpose = getZipList . traverse ZipList++-- | Check for each statement whether it's structurally equal to the first one.+allEqual :: ConstExprs -> [StmtAnnot a] -> Bool+allEqual _ []      = True+allEqual ce (x:xs) = all (StructuralEquality.eqStmtAnnot ce x) xs
+ src/Language/GLSL/Optimizer/FunctionGenerator.hs view
@@ -0,0 +1,7 @@+module Language.GLSL.Optimizer.FunctionGenerator where++import           Language.GLSL.Types+++makeFunction :: [StmtAnnot a] -> TopDecl a+makeFunction _ = ProcDecl ProcMain [] []
+ src/Language/GLSL/Optimizer/Liveness.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GLSL.Optimizer.Liveness where++import qualified Data.IntSet            as S+import qualified Data.Text.Lazy.Builder as LTB+import           Language.GLSL.Types    hiding (t)+++newtype Liveness = Liveness { unLiveness :: S.IntSet }++empty :: Liveness+empty = Liveness S.empty++instance Annot Liveness where+  parseAnnot = pure empty+  ppAnnot = Just . LTB.fromString . show . S.toList . unLiveness+++computeLiveness :: GLSL a -> GLSL Liveness+computeLiveness (GLSL v d) = GLSL v (map clTopDecl d)++clTopDecl :: TopDecl a -> TopDecl Liveness+clTopDecl (LayoutDecl s d) = LayoutDecl s d+clTopDecl (GlobalDecl d) = GlobalDecl d+clTopDecl (ProcDecl name params ss) =+  ProcDecl name params . fst . clStmtAnnots empty $ ss++clStmtAnnots :: Liveness -> [StmtAnnot a] -> ([StmtAnnot Liveness], Liveness)+clStmtAnnots ls = foldr clStmtAnnot ([], ls)++clStmtAnnot+  :: StmtAnnot a+  -> ([StmtAnnot Liveness], Liveness)+  -> ([StmtAnnot Liveness], Liveness)+clStmtAnnot (SA _ s) (ss, ls) =+  let (s', ls') = clStmt s ls in+  (SA ls' s':ss, ls')++clStmt :: Stmt a -> Liveness -> (Stmt Liveness, Liveness)+clStmt (AssignStmt n e) ls =+  (AssignStmt n e, clExpr e ls)+clStmt (DeclStmt d@(LDecl _ (NameId n) e)) ls =+  (DeclStmt d, delete n . maybe id clExpr e $ ls)+clStmt (EmitStmt e) ls =+  (EmitStmt e, clEmit e ls)+clStmt (IfStmt (NameId c) t e) ls =+  let (t', lsT) = clStmtAnnots ls t+      (e', lsE) = clStmtAnnots ls e+  in+  (IfStmt (NameId c) t' e', insert c $ lsT `union` lsE)+++clEmit :: Emit -> Liveness -> Liveness+clEmit EmitFragDepth    = id+clEmit (EmitPosition e) = clExpr e++clExpr :: Expr -> Liveness -> Liveness+clExpr (UnaryExpr _ e) ls      = clExprAtom e ls+clExpr (BinaryExpr l _ r) ls   = clExprAtom l . clExprAtom r $ ls+clExpr (FunCallExpr _ args) ls = foldr clExprAtom ls args+clExpr (TextureExpr t x y) ls  = foldr clExprAtom ls [t, x, y]+clExpr (AtomExpr e) ls         = clExprAtom e ls++clExprAtom :: ExprAtom -> Liveness -> Liveness+clExprAtom (IdentifierExpr n) ls         = clNameExpr n ls+clExprAtom (SwizzleExpr (NameId n) _) ls = insert n ls+clExprAtom _ ls                          = ls++clNameExpr :: NameExpr -> Liveness -> Liveness+clNameExpr (NameExpr (Name NsT (NameId n))) ls = insert n ls+clNameExpr _ ls                                = ls++insert :: Int -> Liveness -> Liveness+insert n = Liveness . S.insert n . unLiveness++delete :: Int -> Liveness -> Liveness+delete n = Liveness . S.delete n . unLiveness++union :: Liveness -> Liveness -> Liveness+union a b = Liveness $ S.union (unLiveness a) (unLiveness b)
+ src/Language/GLSL/Runtime/Eval.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE StrictData                 #-}+{-# LANGUAGE ViewPatterns               #-}+module Language.GLSL.Runtime.Eval where++import           Control.Lens                     ((^.))+import           Control.Monad                    (foldM, foldM_)+import           Control.Monad.Trans.State.Strict (evalStateT, get, modify')+import qualified Data.IntMap                      as M+import qualified Data.Text.Lazy                   as LT+import qualified Data.Text.Lazy.IO                as IO+import qualified Debug.Trace                      as Trace+import           Language.GLSL.Decls              (addDecl, addDeclN, addDeclNE,+                                                   emptyDecls, getDeclNE,+                                                   toUniformId)+import qualified Language.GLSL.Runtime.PrimFuns   as PrimFuns+import           Language.GLSL.Runtime.Value      (Eval, EvalResult (..),+                                                   EvalState (..), Proc (..),+                                                   Value (..), defaultValue,+                                                   evalBinaryOp, evalCoerce,+                                                   evalUnaryOp, isNaNValue,+                                                   roundValue)+import           Language.GLSL.Types+import           Linear                           (R1 (..), R2 (..), R3 (..),+                                                   R4 (..))+++traceAssignments :: Bool+traceAssignments = False++trace :: String -> a -> a+trace = if traceAssignments then Trace.trace else const id+++eval :: LT.Text -> Either String Value+eval code = do+  glsl <- parseShader code+  fromResult $ evalStateT (evalGLSL glsl) startState+++startState :: EvalState+startState = EvalState+  { stProcs = M.empty+  , stMainProc = Nothing++  , globals = emptyDecls+  , gl_Position = Nothing+  }+++evalGLSL :: GLSL () -> Eval Value+evalGLSL (GLSL _ d) = do+  mapM_ discoverTopDecl d+  evalMain+  -- maybe (FloatValue 0) id . gl_Position <$> get+  roundValue <$> getValue emptyLocals (NameExpr (Name NsOut (NameId 0)))++discoverTopDecl :: TopDecl () -> Eval ()+discoverTopDecl (LayoutDecl _ d) = discoverGlobalDecl d+discoverTopDecl (GlobalDecl d) = discoverGlobalDecl d+discoverTopDecl (ProcDecl ProcMain params body) =+  modify' $ \st -> st{stMainProc = Just $ Proc params body}+discoverTopDecl (ProcDecl (ProcName (NameId n)) params body) =+  modify' $ \st@EvalState{..} -> st{stProcs = M.insert n (Proc params body) stProcs}++discoverGlobalDecl :: GlobalDecl -> Eval ()+discoverGlobalDecl (GDecl GkUniform (TyStruct _ fields) (Name NsU n)) =+  modify' $ \st@EvalState{..} ->+    st{globals = foldr (\(ty, m) -> addDecl NsU (toUniformId (n, m)) (defaultValue ty)) globals fields}+discoverGlobalDecl (GDecl GkOut ty n) =+  modify' $ \st@EvalState{..} -> st{globals = addDeclN n (defaultValue ty) globals}+discoverGlobalDecl (GDecl GkIn ty n) =+  modify' $ \st@EvalState{..} -> st{globals = addDeclN n (defaultValue ty) globals}+discoverGlobalDecl d@(GDecl GkUniform _ _) =+  fail $ "unsupported uniform type in decl: " <> pp ppGlobalDecl d+++evalMain :: Eval ()+evalMain = do+  Just mainProc <- stMainProc <$> get+  evalProc mainProc []+  return ()++newtype LocalState = LocalState+  { temps :: M.IntMap Value+  }++emptyLocals :: LocalState+emptyLocals = LocalState+  { temps = M.empty+  }++evalProc :: Proc -> [Value] -> Eval ()+evalProc (Proc _params ss) _args =+  foldM_ evalStmtAnnot emptyLocals ss++evalStmtAnnot :: LocalState -> StmtAnnot () -> Eval LocalState+evalStmtAnnot lst (SA () s) = evalStmt lst s++evalStmt :: LocalState -> Stmt () -> Eval LocalState+evalStmt lst (AssignStmt n e) = do+  v <- evalExpr lst e+  setValue lst (NameExpr n) v+evalStmt lst (DeclStmt d) = evalLocalDecl lst d+evalStmt lst (EmitStmt e) = evalEmit lst e+evalStmt lst (IfStmt cond thens elses) = do+  BoolValue v <- getValue lst (NameExpr (Name NsT cond))+  if v+    then foldM evalStmtAnnot lst thens+    else foldM evalStmtAnnot lst elses++evalEmit :: LocalState -> Emit -> Eval LocalState+evalEmit lst EmitFragDepth = return lst+evalEmit lst (EmitPosition e) = do+  v <- evalExpr lst e+  modify' $ \st -> st{gl_Position = Just v}+  return lst++evalLocalDecl :: LocalState -> LocalDecl -> Eval LocalState+evalLocalDecl lst (LDecl ty (NameExpr . Name NsT -> n) Nothing) =+  let v = defaultValue ty in+  setValue lst n v+evalLocalDecl lst (LDecl ty (NameExpr . Name NsT -> n) (Just e)) = do+  v <- evalExpr lst e >>= evalCoerce ty+  setValue lst n v++evalExpr :: LocalState -> Expr -> Eval Value+evalExpr lst = \case+  BinaryExpr l op r -> do+    lv <- evalExprAtom lst l+    rv <- evalExprAtom lst r+    return $ evalBinaryOp lv op rv+  UnaryExpr op e -> do+    v <- evalExprAtom lst e+    return $ evalUnaryOp op v+  AtomExpr e -> evalExprAtom lst e+  FunCallExpr fun args -> do+    vals <- mapM (evalExprAtom lst) args+    PrimFuns.eval fun vals+  e@TextureExpr{} ->+    fail $ "texture() not implemented: " <> pp ppExpr e++evalExprAtom :: LocalState -> ExprAtom -> Eval Value+evalExprAtom lst = \case+  LitFloatExpr _ f   -> return $ FloatValue f+  LitIntExpr _ i     -> return $ IntValue i+  IdentifierExpr n   -> getValue lst n+  SwizzleExpr n s    -> getValue lst (NameExpr (Name NsT n)) >>= evalVecIndex s+  VecIndexExpr n i   -> getValue lst n >>= evalVecIndex i+  MatIndexExpr n i j -> getValue lst n >>= evalMatIndex i j++evalVecIndex :: Swizzle -> Value -> Eval Value+evalVecIndex X (Vec2Value v) = return $ FloatValue $ v ^. _x+evalVecIndex Y (Vec2Value v) = return $ FloatValue $ v ^. _y+evalVecIndex X (Vec3Value v) = return $ FloatValue $ v ^. _x+evalVecIndex Y (Vec3Value v) = return $ FloatValue $ v ^. _y+evalVecIndex Z (Vec3Value v) = return $ FloatValue $ v ^. _z+evalVecIndex X (Vec4Value v) = return $ FloatValue $ v ^. _x+evalVecIndex Y (Vec4Value v) = return $ FloatValue $ v ^. _y+evalVecIndex Z (Vec4Value v) = return $ FloatValue $ v ^. _z+evalVecIndex W (Vec4Value v) = return $ FloatValue $ v ^. _w+evalVecIndex s v = fail $ "cannot access " <> pp ppSwizzle s <> " on " <> show v++evalMatIndex :: Swizzle -> Swizzle -> Value -> Eval Value+evalMatIndex i j (Mat4x4Value v) =+  return $ FloatValue $ v ^. (swizzle i . swizzle j)+  where+    swizzle X = _x+    swizzle Y = _y+    swizzle Z = _z+    swizzle W = _w+evalMatIndex i j v =+  fail $ "cannot access [" <> pp ppVecIndex i <> "][" <> pp ppVecIndex j <> "]"+      <> " on " <> show v+++setValue :: LocalState -> NameExpr -> Value -> Eval LocalState+setValue lst@LocalState{..} n@(NameExpr (Name NsT (NameId nId))) v =+  trace (pp ppNameExpr n <> " = " <> show v) $+  if isNaNValue v+    then fail $ pp ppNameExpr n <> " = " <> show v+    else return lst{temps = M.insert nId v temps}+setValue lst n v = do+  modify' $ \st@EvalState{..} -> st{globals = addDeclNE n v globals}+  trace (pp ppNameExpr n <> " = " <> show v) $+    if isNaNValue v+      then fail $ pp ppNameExpr n <> " = " <> show v+      else return lst+++getValue :: LocalState -> NameExpr -> Eval Value+getValue LocalState{..} (NameExpr (Name NsT (NameId n))) = do+  let Just v = M.lookup n temps+  return v+getValue _ n = do+  v <- getDeclNE n . globals <$> get+  case v of+    Nothing -> fail $ "undefined global: " <> pp ppNameExpr n+    Just ok -> return ok+++main :: IO ()+main = do+  txt <- IO.readFile "../large-shaders/xax.vert"+  print $ eval txt
+ src/Language/GLSL/Runtime/Math.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+module Language.GLSL.Runtime.Math where++import           Prelude (Float, fromIntegral, max, min, (*), (-), (.), (/),+                          (<))+import qualified Prelude++floor :: Float -> Float+floor = fromIntegral . Prelude.floor++fract :: Float -> Float+fract x = x - floor x++mod :: Float -> Float -> Float+mod x y = x - y * floor (x/y)++clamp :: Float -> Float -> Float -> Float+clamp x a = min (max x a)++saturate :: Float -> Float+saturate x = clamp x 0 1++step :: Float -> Float -> Float+step a x = if x < a then 0 else 1++smoothstep :: Float -> Float -> Float -> Float+smoothstep a b x = let t = saturate ((x-a) / (b-a)) in t*t*(3-2*t)
+ src/Language/GLSL/Runtime/PrimFuns.hs view
@@ -0,0 +1,71 @@+module Language.GLSL.Runtime.PrimFuns where++import           Control.Monad               ((>=>))+import           Language.GLSL.Runtime.Math  (floor, fract, mod, smoothstep,+                                              step)+import           Language.GLSL.Runtime.Value (Eval, Value (..), evalCoerce)+import           Language.GLSL.Types         (FunName (..), Type (..), pp,+                                              ppFunName)+import           Linear+import           Prelude                     hiding (floor, mod)++flt :: Value -> Eval Float+flt = evalCoerce TyFloat >=> convert+  where+    convert (FloatValue v) = pure v+    convert v              = fail $ "not a Float value: " <> show v++v4 :: Value -> Eval (V4 Float)+v4 = evalCoerce (TyVec 4) >=> convert+  where+    convert (Vec4Value v) = pure v+    convert v             = fail $ "not a V4 value: " <> show v+++eval :: FunName -> [Value] -> Eval Value+eval PrimVec2 [x, y] =+  fmap Vec2Value $ V2+    <$> flt x+    <*> flt y+eval PrimVec3 [x, y, z] =+  fmap Vec3Value $ V3+    <$> flt x+    <*> flt y+    <*> flt z+eval PrimVec4 [x, y, z, w] =+  fmap Vec4Value $ V4+    <$> flt x+    <*> flt y+    <*> flt z+    <*> flt w++eval PrimMat4x4 [x, y, z, w] =+  fmap Mat4x4Value $ V4+    <$> v4 x+    <*> v4 y+    <*> v4 z+    <*> v4 w++eval PrimLength [Vec2Value a] = pure $ FloatValue $ norm a+eval PrimLength [Vec3Value a] = pure $ FloatValue $ norm a+eval PrimLength [Vec4Value a] = pure $ FloatValue $ norm a++eval PrimNormalize [Vec2Value a] = pure $ Vec2Value $ signorm a+eval PrimNormalize [Vec3Value a] = pure $ Vec3Value $ signorm a+eval PrimNormalize [Vec4Value a] = pure $ Vec4Value $ signorm a++eval PrimSqrt   [a] = FloatValue      . sqrt   <$> flt a+eval PrimSin    [a] = FloatValue      . sin    <$> flt a+eval PrimAsin   [a] = FloatValue      . asin   <$> flt a+eval PrimCos    [a] = FloatValue      . cos    <$> flt a+eval PrimAbs    [a] = FloatValue      . abs    <$> flt a+eval PrimFloor  [a] = FloatValue      . floor  <$> flt a+eval PrimFract  [a] = FloatValue      . fract  <$> flt a+eval PrimMod  [a,b] = fmap FloatValue $ mod    <$> flt a <*> flt b+eval PrimAtan [a,b] = fmap FloatValue $ atan2  <$> flt a <*> flt b++eval PrimSmoothstep [a,b,c] = fmap FloatValue $ smoothstep <$> flt a <*> flt b <*> flt c+eval PrimStep         [a,b] = fmap FloatValue $ step <$> flt a <*> flt b++-- eval _ (a:_) = pure a+eval fun _ = fail $ "primfun not implemented: " <> pp ppFunName fun
+ src/Language/GLSL/Runtime/Value.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData                 #-}+module Language.GLSL.Runtime.Value where++import           Control.Monad.Trans.State.Strict (StateT)+import qualified Data.IntMap                      as M+import           Language.GLSL.Decls              (Decls)+import           Language.GLSL.Types+import           Linear                           (M44, V2, V3, V4, (!*!), (!*))++data Proc+  = Proc [ParamDecl] [StmtAnnot ()]++data EvalState = EvalState+  { stProcs     :: M.IntMap Proc+  , stMainProc  :: Maybe Proc++  , globals     :: Decls Value+  , gl_Position :: Maybe Value+  }++newtype EvalResult a = EvalResult { fromResult :: Either String a }+  deriving (Functor, Applicative, Monad)++instance MonadFail EvalResult where+  fail = EvalResult . Left++type Eval = StateT EvalState EvalResult++data Value+  = FloatValue Float+  | IntValue Int+  | BoolValue Bool+  | Vec2Value (V2 Float)+  | Vec3Value (V3 Float)+  | Vec4Value (V4 Float)+  | Mat4x4Value (M44 Float)+  deriving (Show, Eq)+++defaultValue :: Type -> Value+defaultValue TyFloat   = FloatValue 0+defaultValue (TyVec 2) = Vec2Value 0+defaultValue (TyVec 3) = Vec3Value 0+defaultValue (TyVec 4) = Vec4Value 0+defaultValue ty        = error $ "defaultValue not implemented: " <> pp ppType ty+++isNaNValue :: Value -> Bool+isNaNValue (FloatValue v) = isNaN v+isNaNValue _              = False+++roundValue :: Value -> Value+roundValue (FloatValue v) =+  FloatValue $ fromIntegral (round (v * 100000) :: Integer) / 100000+roundValue v = v+++evalCoerce :: Type -> Value -> Eval Value+evalCoerce TyFloat v@FloatValue{} = return v+evalCoerce TyBool v@BoolValue{} = return v+evalCoerce TyFloat (IntValue i)   = return $ FloatValue (fromIntegral i)+evalCoerce (TyVec 2) v@Vec2Value{}     = return v+evalCoerce (TyVec 3) v@Vec3Value{}     = return v+evalCoerce (TyVec 4) v@Vec4Value{}     = return v+evalCoerce (TyMat 4 4) v@Mat4x4Value{} = return v+evalCoerce ty v                        = fail $ "coerce failed: " <> show (ty, v)+++evalBinaryOp :: Value -> BinaryOp -> Value -> Value+evalBinaryOp (FloatValue l) BOpPlus (FloatValue r)  = FloatValue (l + r)+evalBinaryOp (FloatValue l) BOpMinus (FloatValue r) = FloatValue (l - r)+evalBinaryOp (FloatValue l) BOpMul (FloatValue r)   = FloatValue (l + r)+evalBinaryOp (FloatValue l) BOpDiv (FloatValue r)   = FloatValue (l / r)+evalBinaryOp (FloatValue l) BOpLE (FloatValue r)    = BoolValue (l <= r)+evalBinaryOp (FloatValue l) BOpGE (FloatValue r)    = BoolValue (l >= r)+evalBinaryOp (FloatValue l) BOpLT (FloatValue r)    = BoolValue (l < r)+evalBinaryOp (FloatValue l) BOpGT (FloatValue r)    = BoolValue (l > r)++evalBinaryOp (IntValue l) BOpPlus (IntValue r)      = IntValue (l + r)+evalBinaryOp (IntValue l) BOpMinus (IntValue r)     = IntValue (l - r)+evalBinaryOp (IntValue l) BOpMul (IntValue r)       = IntValue (l * r)++evalBinaryOp (Vec4Value l) BOpMul (Mat4x4Value r)   = Vec4Value (r !* l)+evalBinaryOp (Mat4x4Value l) BOpMul (Mat4x4Value r) = Mat4x4Value (r !*! l)++evalBinaryOp l@FloatValue{} o (IntValue r) = evalBinaryOp l o (FloatValue $ fromIntegral r)+evalBinaryOp (IntValue l) o r@FloatValue{} = evalBinaryOp (FloatValue $ fromIntegral l) o r++evalBinaryOp l o r =+  error $ "not implemented: " <> show (l, o, r)+++evalUnaryOp :: UnaryOp -> Value -> Value+evalUnaryOp UOpMinus (FloatValue v) = FloatValue (-v)+evalUnaryOp UOpMinus (IntValue v) = IntValue (-v)++evalUnaryOp o e =+  error $ "not implemented: " <> show (o, e)
+ src/Language/GLSL/StructuralEquality.hs view
@@ -0,0 +1,90 @@+-- | Structural equality, ignoring the variable names.+module Language.GLSL.StructuralEquality where++import           Language.GLSL.ConstExpr (ConstExprs, isConstExpr)+import           Language.GLSL.Types+++eqStmtAnnots :: ConstExprs -> [(StmtAnnot a, StmtAnnot a)] -> Bool+eqStmtAnnots ce = all (uncurry (eqStmtAnnot ce))++eqStmtAnnot :: ConstExprs -> StmtAnnot a -> StmtAnnot a -> Bool+eqStmtAnnot ce (SA _ a) (SA _ b) = eqStmt ce a b+++eqStmt :: ConstExprs -> Stmt a -> Stmt a -> Bool+eqStmt ce (AssignStmt _ ea) (AssignStmt _ eb) =+  -- We consider constant expressions to be equal, since we can just pass that+  -- constant into the function as an argument. Most of the time, it's small+  -- things like 1.0 or (-1.0) (possibly in a t-var, hence the ConstExprs set).+  isConstExpr ce ea && isConstExpr ce eb ||+  eqExpr ea eb+eqStmt _ (DeclStmt da) (DeclStmt db) =+  eqLocalDecl da db+eqStmt _ (EmitStmt ea) (EmitStmt eb) =+  eqEmit ea eb+eqStmt ce (IfStmt _ ta ea) (IfStmt _ tb eb) =+  eqStmtAnnots ce (zip ta tb) &&+  eqStmtAnnots ce (zip ea eb)+eqStmt _ _ _ = False+++eqExpr :: Expr -> Expr -> Bool+eqExpr (AtomExpr ea) (AtomExpr eb) =+  eqExprAtom ea eb+eqExpr (UnaryExpr ua ea) (UnaryExpr ub eb) =+  ua == ub && eqExprAtom ea eb+eqExpr (FunCallExpr fa aa) (FunCallExpr fb ab) =+  fa == fb && all (uncurry eqExprAtom) (zip aa ab)+eqExpr (TextureExpr ta xa ya) (TextureExpr tb xb yb) =+  all (uncurry eqExprAtom) [(ta, tb), (xa, xb), (ya, yb)]+eqExpr (BinaryExpr la oa ra) (BinaryExpr lb ob rb) =+  oa == ob && eqExprAtom la lb && eqExprAtom ra rb+eqExpr _ _ =+  False+++eqExprAtom :: ExprAtom -> ExprAtom -> Bool+eqExprAtom (LitIntExpr _ _) (LitIntExpr _ _)             = True+eqExprAtom (LitIntExpr _ _) (LitFloatExpr _ _)           = True+eqExprAtom (LitFloatExpr _ _) (LitFloatExpr _ _)         = True+eqExprAtom (LitFloatExpr _ _) (LitIntExpr _ _)           = True+eqExprAtom (IdentifierExpr a) (IdentifierExpr b)         = eqNameExpr a b+eqExprAtom (SwizzleExpr _ a) (SwizzleExpr _ b)           = a == b+eqExprAtom (VecIndexExpr _ ia) (VecIndexExpr _ ib)       = ia == ib+eqExprAtom (MatIndexExpr _ ia ja) (MatIndexExpr _ ib jb) = ia == ib && ja == jb+eqExprAtom _ _                                           = False++-- | All variable names are equal.+--+--   We used to ignore temporary names only, considering all other names as+--   globals and a fixed part of the code. This check is quite expensive and it+--   turns out that most of the time the global variables *are* the same. If+--   they are not, we'll need to pass them as arguments to our new function, but+--   this is rare enough so it won't increase the average function parameter+--   list length too much.+eqNameExpr :: NameExpr -> NameExpr -> Bool+eqNameExpr (UniformExpr na ma) (UniformExpr nb mb) = na == nb && ma == mb+-- eqName (Name NsT _) (Name NsT _)   = True+-- eqName (Name nsa na) (Name nsb nb) = nsa == nsb && na == nb+eqNameExpr _ _                                     = True++eqLocalDecl :: LocalDecl -> LocalDecl -> Bool+eqLocalDecl (LDecl tya _ ea) (LDecl tyb _ eb) =+  eqType tya tyb && eqMaybe eqExpr ea eb+++eqType :: Type -> Type -> Bool+eqType = (==)+++eqEmit :: Emit -> Emit -> Bool+eqEmit (EmitPosition a) (EmitPosition b) = eqExpr a b+eqEmit EmitFragDepth EmitFragDepth       = True+eqEmit _ _                               = False+++eqMaybe :: (a -> a -> Bool) -> Maybe a -> Maybe a -> Bool+eqMaybe f (Just a) (Just b) = f a b+eqMaybe _ Nothing Nothing   = True+eqMaybe _ _ _               = False
+ src/Language/GLSL/Types.hs view
@@ -0,0 +1,650 @@+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData        #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Language.GLSL.Types where++import           Control.Applicative              (Applicative (..), (<|>))+import           Data.Attoparsec.ByteString.Char8 (IResult (Partial), Parser,+                                                   char, decimal, endOfInput,+                                                   many1, option, parse,+                                                   parseOnly, rational,+                                                   scientific, sepBy1)+import           Data.List                        (intersperse)+import qualified Data.Scientific                  as Sci+import qualified Data.Text.Encoding               as T+import qualified Data.Text.Lazy                   as LT+import qualified Data.Text.Lazy.Builder           as LTB+import qualified Data.Text.Lazy.Builder.Int       as LTB+import qualified Data.Text.Lazy.Builder.RealFloat as LTB+++parseShader :: Annot a => LT.Text -> Either String (GLSL a)+parseShader = parseOnly parseGLSL . T.encodeUtf8 . LT.toStrict++printShader :: Annot a => GLSL a -> LT.Text+printShader = LTB.toLazyText . ppGLSL+++data GLSL a = GLSL Version [TopDecl a]+  deriving (Show, Functor, Foldable, Traversable)++parseGLSL :: Annot a => Parser (GLSL a)+parseGLSL = GLSL+  <$> parseVersion+  <*> ("\n" >> many1 parseTopDecl >>= (endOfInput >>) . pure)++ppGLSL :: Annot a => GLSL a -> LTB.Builder+ppGLSL (GLSL v decls) =+  ppVersion v+  <> "\n" <> ppL ppTopDecl decls++newtype Version = Version Int+  deriving (Show)++parseVersion :: Parser Version+parseVersion = Version <$> ("#version " >> decimal)++ppVersion :: Version -> LTB.Builder+ppVersion (Version v) = "#version " <> ppInt v++data TopDecl a+  = LayoutDecl LayoutSpec GlobalDecl+  | GlobalDecl GlobalDecl+  | ProcDecl ProcName [ParamDecl] [StmtAnnot a]+  deriving (Show, Functor, Foldable, Traversable)++parseTopDecl :: Annot a => Parser (TopDecl a)+parseTopDecl = layoutDecl <|> globalDecl <|> procDecl+  where+    layoutDecl = LayoutDecl+      <$> ("layout(" >> parseLayoutSpec)+      <*> (") " >> parseGlobalDecl)++    globalDecl = GlobalDecl+      <$> parseGlobalDecl++    procDecl = ProcDecl+      <$> ("void " >> parseProcName)+      <*> ("() " >> pure [])+      -- <*> ("{\n" >> many1 parseStmtAnnot)+      <*> ("{\n" >> many1 parseStmtAnnot >>= ("}\n" >>) . pure)++ppTopDecl :: Annot a => TopDecl a -> LTB.Builder+ppTopDecl (LayoutDecl e d) = "layout(" <> ppLayoutSpec e <> ") " <> ppGlobalDecl d+ppTopDecl (GlobalDecl d) = ppGlobalDecl d+ppTopDecl (ProcDecl n a b) =+  "void " <> ppProcName n+  <> "(" <> ppS "," ppParamDecl a <> ") {\n"+  <> ppL ppStmtAnnot b+  <> "}\n"++data ProcName+  = ProcMain+  | ProcName NameId+  deriving (Show)++parseProcName :: Parser ProcName+parseProcName =+  ("main" >> pure ProcMain)+  <|> ("p" >> ProcName <$> parseNameId)++ppProcName :: ProcName -> LTB.Builder+ppProcName ProcMain     = "main"+ppProcName (ProcName n) = "p" <> ppNameId n++data LayoutSpec+  = LayoutStd140+  | LayoutLocation Int+  deriving (Show)++parseLayoutSpec :: Parser LayoutSpec+parseLayoutSpec =+  ("std140" >> pure LayoutStd140)+  <|> ("location = " >> LayoutLocation <$> decimal)++ppLayoutSpec :: LayoutSpec -> LTB.Builder+ppLayoutSpec LayoutStd140       = "std140"+ppLayoutSpec (LayoutLocation l) = "location = " <> ppInt l++data ParamDecl+  = Param ParamKind LocalDecl+  deriving (Show)++parseParamDecl :: Parser ParamDecl+parseParamDecl = Param+  <$> parseParamKind+  <*> (" " >> parseLocalDecl)++ppParamDecl :: ParamDecl -> LTB.Builder+ppParamDecl (Param k d) =+  ppParamKind k <> " " <> ppLocalDecl d++data ParamKind+  = PkIn+  | PkOut+  | PkInout+  deriving (Show)++parseParamKind :: Parser ParamKind+parseParamKind = (char ' ' <|> pure ' ') >>+  ("in" >> return PkIn) <|>+  ("out" >> return PkOut) <|>+  ("inout" >> return PkInout)++ppParamKind :: ParamKind -> LTB.Builder+ppParamKind PkIn    = "in"+ppParamKind PkOut   = "out"+ppParamKind PkInout = "inout"++data LocalDecl+  = LDecl Type NameId (Maybe Expr)+  deriving (Show)++parseLocalDecl :: Parser LocalDecl+parseLocalDecl = LDecl+  <$> parseType+  <*> (" t" >> parseNameId)+  <*> (option Nothing (" = " >> Just <$> parseExpr) >>= (";\n" >>) . pure)++ppLocalDecl :: LocalDecl -> LTB.Builder+ppLocalDecl (LDecl t n Nothing) =+  ppType t+  <> " t" <> ppNameId n <> ";\n"+ppLocalDecl (LDecl t n (Just e)) =+  ppType t+  <> " t" <> ppNameId n+  <> " = " <> ppExpr e <> ";\n"++data GlobalDecl+  = GDecl GDeclKind Type Name+  deriving (Show)++parseGlobalDecl :: Parser GlobalDecl+parseGlobalDecl = GDecl+  <$> parseGDeclKind+  <*> (" " >> parseType)+  <*> (" " >> parseName >>= (";\n" >>) . pure)++ppGlobalDecl :: GlobalDecl -> LTB.Builder+ppGlobalDecl (GDecl k t n) =+  ppGDeclKind k+  <> " " <> ppType t+  <> " " <> ppName n <> ";\n"++data GDeclKind+  = GkIn+  | GkOut+  | GkUniform+  deriving (Show)++parseGDeclKind :: Parser GDeclKind+parseGDeclKind =+  ("in" >> return GkIn) <|>+  ("out" >> return GkOut) <|>+  ("uniform" >> return GkUniform)++ppGDeclKind :: GDeclKind -> LTB.Builder+ppGDeclKind GkIn      = "in"+ppGDeclKind GkOut     = "out"+ppGDeclKind GkUniform = "uniform"++data Type+  = TyBool+  | TyFloat+  | TySampler2D+  | TyVec Int+  | TyMat Int Int+  | TyStruct NameId [(Type, NameId)]+  deriving (Show, Eq)++parseType :: Parser Type+parseType =+  ("bool" >> return TyBool)+  <|> ("float" >> return TyFloat)+  <|> ("sampler2D" >> return TySampler2D)+  <|> ("vec" >> TyVec <$> decimal)+  <|> ("mat" >> TyMat <$> decimal <*> ("x" >> decimal))+  <|> tyStruct+  where+    tyStruct = TyStruct+      <$> ("uBlock" >> parseNameId)+      <*> (" {\n" >> many1 parseStructMember >>= ("}" >>) . pure)++    parseStructMember :: Parser (Type, NameId)+    parseStructMember = (,)+      <$> parseType+      <*> (" u" >> parseNameId >>= (";\n" >>) . pure)++ppType :: Type -> LTB.Builder+ppType TyBool = "bool"+ppType TyFloat = "float"+ppType TySampler2D = "sampler2D"+ppType (TyVec n) = "vec" <> ppInt n+ppType (TyMat n m) = "mat" <> ppInt n <> "x" <> ppInt m+ppType (TyStruct n ms) =+  "uBlock" <> ppNameId n+  <> " {\n" <> ppL ppStructMember ms <> "}"+  where ppStructMember (t, n) = ppType t <> " u" <> ppNameId n <> ";\n"++newtype NameId = NameId Int+  deriving (Show, Eq)++parseNameId :: Parser NameId+parseNameId = NameId+  <$> decimal++ppNameId :: NameId -> LTB.Builder+ppNameId (NameId n) = ppInt n++data Name+  = Name Namespace NameId+  deriving (Show)++parseName :: Parser Name+parseName = Name+  <$> parseNamespace+  <*> parseNameId++ppName :: Name -> LTB.Builder+ppName (Name ns n) = ppNamespace ns <> ppNameId n++data Namespace+  = NsT+  | NsS+  | NsU+  | NsVF+  | NsIn+  | NsOut+  deriving (Show, Eq)++parseNamespace :: Parser Namespace+parseNamespace =+  ("in" >> pure NsIn)+  <|> ("out" >> pure NsOut)+  <|> ("vf" >> pure NsVF)+  <|> (char 't' >> pure NsT)+  <|> (char 'u' >> pure NsU)+  <|> (char 's' >> pure NsS)++ppNamespace :: Namespace -> LTB.Builder+ppNamespace NsT   = "t"+ppNamespace NsS   = "s"+ppNamespace NsU   = "u"+ppNamespace NsVF  = "vf"+ppNamespace NsIn  = "in"+ppNamespace NsOut = "out"++data FunName+  = PrimMain+  | PrimMat3x3+  | PrimMat4x4+  | PrimVec2+  | PrimVec3+  | PrimVec4+  | PrimPow+  | PrimDot+  | PrimCos+  | PrimAtan+  | PrimMod+  | PrimAbs+  | PrimCross+  | PrimLength+  | PrimAsin+  | PrimSmoothstep+  | PrimStep+  | PrimFract+  | PrimFloor+  | PrimSin+  | PrimTan+  | PrimSqrt+  | PrimNormalize+  deriving (Show, Eq)++parseFunName :: Parser FunName+parseFunName =+  ("main" >> pure PrimMain)+  <|> ("mat3x3" >> pure PrimMat3x3)+  <|> ("mat4x4" >> pure PrimMat4x4)+  <|> ("vec2" >> pure PrimVec2)+  <|> ("vec3" >> pure PrimVec3)+  <|> ("vec4" >> pure PrimVec4)+  <|> ("pow" >> pure PrimPow)+  <|> ("dot" >> pure PrimDot)+  <|> ("cos" >> pure PrimCos)+  <|> ("atan" >> pure PrimAtan)+  <|> ("mod" >> pure PrimMod)+  <|> ("abs" >> pure PrimAbs)+  <|> ("cross" >> pure PrimCross)+  <|> ("length" >> pure PrimLength)+  <|> ("asin" >> pure PrimAsin)+  <|> ("smoothstep" >> pure PrimSmoothstep)+  <|> ("step" >> pure PrimStep)+  <|> ("fract" >> pure PrimFract)+  <|> ("floor" >> pure PrimFloor)+  <|> ("sin" >> pure PrimSin)+  <|> ("tan" >> pure PrimTan)+  <|> ("sqrt" >> pure PrimSqrt)+  <|> ("normalize" >> pure PrimNormalize)++ppFunName :: FunName -> LTB.Builder+ppFunName PrimMain       = "main"+ppFunName PrimMat3x3     = "mat3x3"+ppFunName PrimMat4x4     = "mat4x4"+ppFunName PrimVec2       = "vec2"+ppFunName PrimVec3       = "vec3"+ppFunName PrimVec4       = "vec4"+ppFunName PrimPow        = "pow"+ppFunName PrimDot        = "dot"+ppFunName PrimCos        = "cos"+ppFunName PrimAtan       = "atan"+ppFunName PrimMod        = "mod"+ppFunName PrimAbs        = "abs"+ppFunName PrimCross      = "cross"+ppFunName PrimLength     = "length"+ppFunName PrimAsin       = "asin"+ppFunName PrimSmoothstep = "smoothstep"+ppFunName PrimStep       = "step"+ppFunName PrimFract      = "fract"+ppFunName PrimFloor      = "floor"+ppFunName PrimSin        = "sin"+ppFunName PrimTan        = "tan"+ppFunName PrimSqrt       = "sqrt"+ppFunName PrimNormalize  = "normalize"++data Swizzle+  = X | Y | Z | W+  deriving (Show, Eq)++parseSwizzle :: Parser Swizzle+parseSwizzle =+  (char 'x' >> pure X)+  <|> (char 'y' >> pure Y)+  <|> (char 'z' >> pure Z)+  <|> (char 'w' >> pure W)++ppSwizzle :: Swizzle -> LTB.Builder+ppSwizzle X = "x"+ppSwizzle Y = "y"+ppSwizzle Z = "z"+ppSwizzle W = "w"++parseVecIndex :: Parser Swizzle+parseVecIndex =+  (char '0' >> pure X)+  <|> (char '1' >> pure Y)+  <|> (char '2' >> pure Z)+  <|> (char '3' >> pure W)++ppVecIndex :: Swizzle -> LTB.Builder+ppVecIndex X = "0"+ppVecIndex Y = "1"+ppVecIndex Z = "2"+ppVecIndex W = "3"++data NameExpr+  = NameExpr Name+  | UniformExpr NameId NameId+  deriving (Show)++parseNameExpr :: Parser NameExpr+parseNameExpr =+  UniformExpr <$> (char 'u' >> parseNameId) <*> (".u" >> parseNameId)+  <|> NameExpr <$> parseName++ppNameExpr :: NameExpr -> LTB.Builder+ppNameExpr (NameExpr n) = ppName n+ppNameExpr (UniformExpr n m) = "u" <> ppNameId n <> ".u" <> ppNameId m++data Cast+  = Cast+  | NoCast+  deriving (Show)++data ExprAtom+  = LitIntExpr Cast Int+  | LitFloatExpr Cast Float+  | IdentifierExpr NameExpr+  | SwizzleExpr NameId Swizzle+  | VecIndexExpr NameExpr Swizzle+  | MatIndexExpr NameExpr Swizzle Swizzle+  deriving (Show)++parseExprAtom :: Parser ExprAtom+parseExprAtom =+  litNumber <$> scientific+  <|> LitIntExpr Cast <$> ("int(" >> decimal >>= (")" >>) . pure)+  <|> LitFloatExpr Cast <$> ("float(" >> rational >>= (")" >>) . pure)+  <|> SwizzleExpr <$> (char 't' >> parseNameId) <*> (char '.' >> parseSwizzle)+  <|> MatIndexExpr <$> parseNameExpr <*> ("[" >> parseVecIndex) <*> ("][" >> parseVecIndex >>= ("]" >>) . pure)+  <|> VecIndexExpr <$> parseNameExpr <*> ("[" >> parseVecIndex >>= ("]" >>) . pure)+  <|> IdentifierExpr <$> parseNameExpr+  where+    litNumber s =+      let e = Sci.base10Exponent s+          c = Sci.coefficient s+      in if e >= 0+          then LitIntExpr NoCast (fromInteger (c * 10 ^ e))+          else LitFloatExpr NoCast (Sci.toRealFloat s)++ppExprAtom :: ExprAtom -> LTB.Builder+ppExprAtom (LitIntExpr Cast i)     = "int(" <> ppInt i <> ")"+ppExprAtom (LitIntExpr NoCast i)   = ppInt i+ppExprAtom (LitFloatExpr Cast n)   = "float(" <> ppFloat n <> ")"+ppExprAtom (LitFloatExpr NoCast r) = ppFloat r+ppExprAtom (IdentifierExpr n)      = ppNameExpr n+ppExprAtom (SwizzleExpr n m)       = "t" <> ppNameId n <> "." <> ppSwizzle m+ppExprAtom (VecIndexExpr n i)      = ppNameExpr n <> "[" <> ppVecIndex i <> "]"+ppExprAtom (MatIndexExpr n i j)    = ppNameExpr n <> "[" <> ppVecIndex i <> "]" <> "[" <> ppVecIndex j <> "]"++data Expr+  = UnaryExpr UnaryOp ExprAtom+  | BinaryExpr ExprAtom BinaryOp ExprAtom+  | FunCallExpr FunName [ExprAtom]+  | TextureExpr ExprAtom ExprAtom ExprAtom+  | AtomExpr ExprAtom+  deriving (Show)++parseExpr :: Parser Expr+parseExpr =+  (char '(' >> operatorExpr >>= (char ')' >>) . pure)+  <|> textureExpr+  <|> funCallExpr+  <|> AtomExpr <$> parseExprAtom++  where+    operatorExpr =+      BinaryExpr <$> parseExprAtom <*> parseBinaryOp <*> parseExprAtom+      <|> UnaryExpr <$> parseUnaryOp <*> parseExprAtom++    textureExpr = TextureExpr+      <$> ("texture(" >> parseExprAtom)+      <*> (",vec2(" >> parseExprAtom)+      <*> ("," >> parseExprAtom >>= ("))" >>) . pure)++    funCallExpr = FunCallExpr+      <$> parseFunName+      <*> (char '(' >> sepBy1 parseExprAtom (char ',') >>= (char ')' >>) . pure)++ppExpr :: Expr -> LTB.Builder+ppExpr (AtomExpr e) = ppExprAtom e+ppExpr (UnaryExpr o e) = "(" <> ppUnaryOp o <> ppExprAtom e <> ")"+ppExpr (BinaryExpr l o r) = "(" <> ppExprAtom l <> ppBinaryOp o <> ppExprAtom r <> ")"+ppExpr (FunCallExpr n args) = ppFunName n <> "(" <> ppS "," ppExprAtom args <> ")"+ppExpr (TextureExpr t x y) = "texture(" <> ppExprAtom t <> ",vec2(" <> ppExprAtom x <> "," <> ppExprAtom y <> "))"++data BinaryOp+  = BOpPlus+  | BOpMinus+  | BOpMul+  | BOpDiv+  | BOpGE+  | BOpGT+  | BOpLE+  | BOpLT+  | BOpAnd+  | BOpOr+  deriving (Show, Eq)++parseBinaryOp :: Parser BinaryOp+parseBinaryOp =+  (char '+' >> pure BOpPlus)+  <|> (char '-' >> pure BOpMinus)+  <|> (char '*' >> pure BOpMul)+  <|> (char '/' >> pure BOpDiv)+  <|> (">=" >> pure BOpGE)+  <|> (">" >> pure BOpGT)+  <|> ("<=" >> pure BOpLE)+  <|> ("<" >> pure BOpLT)+  <|> ("&&" >> pure BOpAnd)+  <|> ("||" >> pure BOpOr)++ppBinaryOp :: BinaryOp -> LTB.Builder+ppBinaryOp BOpPlus  = "+"+ppBinaryOp BOpMinus = "-"+ppBinaryOp BOpMul   = "*"+ppBinaryOp BOpDiv   = "/"+ppBinaryOp BOpGE    = ">="+ppBinaryOp BOpGT    = ">"+ppBinaryOp BOpLE    = "<="+ppBinaryOp BOpLT    = "<"+ppBinaryOp BOpAnd   = "&&"+ppBinaryOp BOpOr    = "||"++data UnaryOp+  = UOpMinus+  | UOpNot+  deriving (Show, Eq)++parseUnaryOp :: Parser UnaryOp+parseUnaryOp =+  (char '-' >> pure UOpMinus)+  <|> (char '!' >> pure UOpMinus)++ppUnaryOp :: UnaryOp -> LTB.Builder+ppUnaryOp UOpMinus = "-"+ppUnaryOp UOpNot   = "!"++data StmtAnnot a = SA+  { annot   :: a+  , unAnnot :: Stmt a+  }+  deriving (Show, Functor, Foldable, Traversable)++instance Applicative StmtAnnot where+  pure a = SA a (pure a)+  liftA2 f a b = SA (f (annot a) (annot b)) $ liftA2 f (unAnnot a) (unAnnot b)++parseStmtAnnot :: Annot a => Parser (StmtAnnot a)+parseStmtAnnot = SA <$> parseAnnot <*> parseStmt++ppStmtAnnot :: Annot a => StmtAnnot a -> LTB.Builder+ppStmtAnnot (SA a s) =+  maybe "" (\ltb -> "// " <> ltb <> "\n") (ppAnnot a) <> ppStmt s++data Stmt a+  = AssignStmt Name Expr+  | DeclStmt LocalDecl+  | EmitStmt Emit+  | IfStmt NameId [StmtAnnot a] [StmtAnnot a]+  deriving (Show, Functor, Foldable, Traversable)++instance Applicative Stmt where+  -- Arbitrary decision because "pure" doesn't really make sense.+  pure _ = EmitStmt EmitFragDepth++  liftA2 f (IfStmt n t1 e1) (IfStmt _ t2 e2) = IfStmt n+    ((zipWith . liftA2) f t1 t2)+    ((zipWith . liftA2) f e1 e2)+  liftA2 _ (AssignStmt n e) _ = AssignStmt n e+  liftA2 _ (DeclStmt d) _ = DeclStmt d+  liftA2 _ (EmitStmt e) _ = EmitStmt e+  liftA2 _ (IfStmt n _ _) _ = IfStmt n [] []+++parseStmt :: Annot a => Parser (Stmt a)+parseStmt =+  IfStmt <$> ("if(t" >> parseNameId >>= ("){\n" >>) . pure)+         <*> many1 parseStmtAnnot+         <*> ("} else {\n" >> many1 parseStmtAnnot >>= ("}\n" >>) . pure)+  <|> AssignStmt <$> parseName <*> (" = " >> parseExpr >>= (";\n" >>) . pure)+  <|> DeclStmt <$> parseLocalDecl+  <|> EmitStmt <$> parseEmit++ppStmt :: Annot a => Stmt a -> LTB.Builder+ppStmt (AssignStmt n e) = ppName n <> " = " <> ppExpr e <> ";\n"+ppStmt (DeclStmt d) = ppLocalDecl d+ppStmt (EmitStmt e) = ppEmit e+ppStmt (IfStmt c t e) =+  "if(t" <> ppNameId c <> "){\n"+  <> ppL ppStmtAnnot t+  <> "} else {\n"+  <> ppL ppStmtAnnot e+  <> "}\n"++data Emit+  = EmitPosition Expr+  | EmitFragDepth+  deriving (Show)++parseEmit :: Parser Emit+parseEmit =+  EmitPosition <$> ("gl_Position = " >> parseExpr >>= (";\n" >>) . pure)+  <|> ("gl_FragDepth = gl_FragCoord[2];\n" >> pure EmitFragDepth)++ppEmit :: Emit -> LTB.Builder+ppEmit (EmitPosition e) = "gl_Position = " <> ppExpr e <> ";\n"+ppEmit EmitFragDepth    = "gl_FragDepth = gl_FragCoord[2];\n"++ppInt :: Int -> LTB.Builder+ppInt = LTB.decimal++ppFloat :: Float -> LTB.Builder+ppFloat = LTB.realFloat++ppL :: (a -> LTB.Builder) -> [a] -> LTB.Builder+ppL printer = mconcat . map printer++ppS :: LTB.Builder -> (a -> LTB.Builder) -> [a] -> LTB.Builder+ppS sep printer = mconcat . intersperse sep . map printer++class Annot a where+  parseAnnot :: Parser a+  ppAnnot :: a -> Maybe LTB.Builder++instance Annot () where+  parseAnnot = pure ()+  ppAnnot = const Nothing++instance (Annot a, Annot b) => Annot (a, b) where+  parseAnnot = error "not implemented"+  ppAnnot (a, b) = do+    ppA <- ppAnnot a+    ppB <- ppAnnot b+    return $ "(" <> ppA <> ", " <> ppB <> ")"++----------------------------------++parseTest :: Show a => Parser a -> LT.Text -> IO ()+parseTest p input =+  let r = show . fromPartial . parse p . T.encodeUtf8 . LT.toStrict $ input in+  if length r > 600+    then+      let start = take 500 r+          end = reverse $ take 100 $ reverse r+      in+      putStrLn $ start <> " ... " <> end+    else putStrLn r+  where+    fromPartial (Partial cont) = cont mempty+    fromPartial r              = r++t :: Show a => Parser a -> String -> IO ()+t p = parseTest p . LT.pack++pp :: (a -> LTB.Builder) -> a -> String+pp printer = LT.unpack . LTB.toLazyText . printer++ppl :: (a -> LTB.Builder) -> [a] -> String+ppl printer = LT.unpack . LTB.toLazyText . ppL printer
+ test/Language/GLSL/GLSLSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GLSL.GLSLSpec where++import           Test.Hspec                       (Spec, describe, it)++import           Control.Applicative              (liftA2)+import           Data.Attoparsec.ByteString.Char8 (decimal)+import qualified Language.GLSL.Types    as GLSL+import           Test.GLSL                        (Transform, shouldTransformTo,+                                                   with)+++newtype TestAnnot = TestAnnot Int++instance GLSL.Annot TestAnnot where+  parseAnnot = "// " >> TestAnnot <$> decimal >>= ("\n" >>) . pure+  ppAnnot (TestAnnot n) = Just $ GLSL.ppInt n+++testAddAnnot :: [Int] -> Transform () TestAnnot+testAddAnnot = zipWith (fmap . setAnnot)+  where+    setAnnot i () = TestAnnot i+++testJoinAnnot :: Transform () (TestAnnot, TestAnnot)+testJoinAnnot ss =+    let ss1 = testAddAnnot [0..3] ss+        ss2 = testAddAnnot (reverse [0..3]) ss+    in (zipWith . liftA2) (,) ss1 ss2+++spec :: Spec+spec = do+    describe "fmap" $ do+        it "should add annotations" $+            [ "float t1 = 0;"+            , "float t2 = 0.0;"+            , "float t3 = (t2+1.1);"+            , "float t4 = (t3+vf1);"+            ] `with` testAddAnnot [0..3]+            `shouldTransformTo`+            [ "// 0"+            , "float t1 = 0;"+            , "// 1"+            , "float t2 = 0.0;"+            , "// 2"+            , "float t3 = (t2+1.1);"+            , "// 3"+            , "float t4 = (t3+vf1);"+            ]++    describe "liftA2" $ do+        it "should join annotations" $+            [ "float t1 = 0;"+            , "float t2 = 0.0;"+            , "float t3 = (t2+1.1);"+            , "float t4 = (t3+vf1);"+            ] `with` testJoinAnnot+            `shouldTransformTo`+            [ "// (0, 3)"+            , "float t1 = 0;"+            , "// (1, 2)"+            , "float t2 = 0.0;"+            , "// (2, 1)"+            , "float t3 = (t2+1.1);"+            , "// (3, 0)"+            , "float t4 = (t3+vf1);"+            ]
+ test/Language/GLSL/Optimizer/DeinlineSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.GLSL.Optimizer.DeinlineSpec where++import           Test.Hspec                        (Spec, describe, it)++import           Language.GLSL.Optimizer.Deinline (Config (..), defaultConfig,+                                                    diStmts)+import           Test.GLSL                         (Transform,+                                                    shouldNotTransform,+                                                    shouldTransformTo, with)+++-- | Test config has smaller window size so we don't need to write as many+--   lines in our tests.+testConfig :: Config+testConfig = defaultConfig{windowSize=3}++testDI :: Transform () ()+testDI = diStmts testConfig+++spec :: Spec+spec = do+    describe "diStmts" $ do+        it "should leave non-repetitive code alone" $+            shouldNotTransform $+            [ "float t1 = 0;"+            , "float t2 = 0.0;"+            , "float t3 = (t2+1.1);"+            , "float t4 = (t3+vf1);"+            ] `with` testDI++        it "should remove repeated code" $+            [ "float t1 = 0;"+            , "float t2 = 0.0;"+            , "float t3 = (t2+1.1);" -- start of same code+            , "float t4 = (t3+vf1);"+            , "float t5 = (t4*vf1);"+            , "float t6 = (t5/vf1);"+            , "float t7 = (t5-vf1);" -- end of same code+            , "float t8 = (t2+1.1);" -- different code+            , "float t9 = sin(t3);" -- also different+            , "float t10 = (t9+1.1);" -- start of same code+            , "float t11 = (t10+vf1);"+            , "float t12 = (t11*vf1);"+            , "float t13 = (t12/vf1);"+            , "float t14 = (t13-vf1);" -- end of same code+            , "float t15 = cos(t14);" -- different code+            , "float t16 = tan(t15);" -- also different+            ] `with` testDI+            `shouldTransformTo`+            [ "float t1 = 0;"+            , "float t2 = 0.0;"+            , "float t8 = (t2+1.1);" -- different code+            , "float t9 = sin(t3);" -- also different+            , "float t15 = cos(t14);" -- different code+            , "float t16 = tan(t15);" -- also different+            ]
+ test/Test/GLSL.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Test.GLSL where++import           Test.Hspec                        (Expectation, shouldBe)++import           Data.Attoparsec.ByteString.Char8  (many1, parseOnly)+import qualified Data.ByteString.Char8             as BS+import           Data.String                       (fromString)+import qualified Data.Text.Lazy                    as LT+import qualified Data.Text.Lazy.Builder            as LTB+import qualified Language.GLSL.Types     as GLSL+++type Transform a b = [GLSL.StmtAnnot a] -> [GLSL.StmtAnnot b]+type TransformExpectation a b+    = (Transform a b, [BS.ByteString])+    -> [LT.Text]+    -> Expectation++with :: [s] -> Transform a b -> (Transform a b, [s])+with = flip (,)++shouldTransformTo :: (GLSL.Annot a, GLSL.Annot b) => TransformExpectation a b+shouldTransformTo (f, code) expected =+    let Right glsl = parseOnly (many1 GLSL.parseStmtAnnot) $ BS.unlines code+        res = f glsl+    in+    concatMap (LT.lines . LTB.toLazyText . GLSL.ppStmtAnnot) res+    `shouldBe`+    expected++shouldNotTransform+    :: (GLSL.Annot a, GLSL.Annot b)+    => (Transform a b, [String])+    -> Expectation+shouldNotTransform (f, a) =+    shouldTransformTo (f, map fromString a) (map fromString a)
+ test/testsuite.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tools/optshader.hs view
@@ -0,0 +1,49 @@+module Main (main) where++import qualified Data.Text.Lazy              as LT+import qualified Data.Text.Lazy.IO           as IO+import           Data.Time.Clock             as Time (diffUTCTime,+                                                      getCurrentTime,+                                                      nominalDiffTimeToSeconds)+import qualified Language.GLSL.Optimizer     as Opt+import qualified Language.GLSL.Optimizer.DFG as DFG+import qualified Language.GLSL.Types         as GLSL+import qualified System.Environment          as Env++main :: IO ()+main = Env.getArgs >>= mapM_ process++parseShader :: LT.Text -> Either String (GLSL.GLSL ())+parseShader = GLSL.parseShader++process :: FilePath -> IO ()+process inFile = do+  putStrLn "Loading file..."+  inText <- IO.readFile inFile+  putStrLn "Parsing file..."+  case parseShader inText of+    Left err -> fail err+    Right ok -> do+      putStrLn "Generating data flow graph (opt.dot)..."+      let dfg = DFG.genDFG ok+      DFG.toDot "opt.dot" dfg+      -- DFG.toSvg dfg "../opt.svg"+      putStrLn "Optimizing shader (opt.glsl)..."+      s <- Time.getCurrentTime+      let outText = GLSL.printShader $ Opt.optimize ok+      IO.writeFile "opt.glsl" outText+      e <- Time.getCurrentTime+      let elapsed = Time.nominalDiffTimeToSeconds $ Time.diffUTCTime e s+      putStrLn $ "Optimizer took " <> show elapsed <> "s"+      let inLen = LT.length inText+          outLen = LT.length outText+          factor :: Float+          factor = fromIntegral inLen / fromIntegral outLen+      putStrLn $ "Size: " <> showKB inLen <> " -> "+                  <> showKB outLen <> ", " <> show factor <> "x reduction"+++showKB :: (Show a, Integral a) => a -> String+showKB x | x > 1024 * 1024 = show (x `div` (1024 * 1024)) <> "MiB"+showKB x | x > 1024 = show (x `div` 1024) <> "KiB"+showKB x = show x <> "B"