lambdacube-compiler 0.4.0.1 → 0.5.0.0
raw patch · 18 files changed
+4430/−3653 lines, 18 filesdep +JuicyPixelsdep +base64-bytestringdep +megaparsecdep −indentationdep −parsecdep −pretty-compactdep ~aesondep ~basedep ~filepathnew-component:exe:lambdacube-backend-test-servernew-component:exe:lambdacube-compiler-performance-report
Dependencies added: JuicyPixels, base64-bytestring, megaparsec, patience, pretty-show, process, vect, websockets, wl-pprint
Dependencies removed: indentation, parsec, pretty-compact
Dependency ranges changed: aeson, base, filepath, lambdacube-ir
Files
- CHANGELOG.md +92/−0
- backendtest/EditorExamplesTest.hs +228/−0
- backendtest/TestData.hs +242/−0
- backendtest/TestServer.hs +133/−0
- lambdacube-compiler.cabal +64/−16
- lc/Builtins.lc +325/−322
- lc/Internals.lc +40/−20
- lc/Prelude.lc +56/−29
- src/LambdaCube/Compiler.hs +171/−124
- src/LambdaCube/Compiler/CoreToIR.hs +992/−1110
- src/LambdaCube/Compiler/Infer.hs +1505/−1440
- src/LambdaCube/Compiler/Lexer.hs +173/−335
- src/LambdaCube/Compiler/Parser.hs +234/−175
- src/LambdaCube/Compiler/Pretty.hs +8/−2
- test/PerfReport.hs +54/−0
- test/UnitTests.hs +11/−8
- test/runTests.hs +72/−64
- tool/Compiler.hs +30/−8
+ CHANGELOG.md view
@@ -0,0 +1,92 @@++# v0.5++- compiler+ - support local pattern matching functions+ - support recursive local definitions+ - more polymorph type for equality constraints+ (~) :: forall a . a -> a -> Type+ - tuples are representated as heterogeneous lists+ - support one-element tuple syntax: (( element ))+ - reduction: don't overnormalize (String -/-> [Char])+ - compiler optimization: names have Int identifiers+- libraries/OpenGL API+ - use the advantage of heterogeneous lists+ (simplified and more complete type family instances)+ - needed to explicitly denote one-element attribute tuples+ - set programmable point size with ProgramPointSize+ - use lists instead of streams+ - rename+ - fetch_ --> fetch; fetchArrays_ --> fetchArrays+ - zeroComp --> zero; oneComp --> one+- codegen+ - generate functions in shaders (previously functions were inlined)+ - normalized variable names in the generated pipeline+ - optimization: remove duplicate shader programs+ - pretty printed shader programs+ - include compiler version in the generated pipeline as a string info field+- testenv+ - performance benchmarks (time and memory consumption)+- other+ - parsec dependency changed to megaparsec+ - registered on stackage too (next to HackageDB)+++# v0.4 - tagged on Feb 5, 2016++- compiler+ - support type synonyms+ - support simple import lists (hiding + explicit)+ - support multiple guards+ - handle constructor operator fixities, also in patterns+ - definitions are allowed in any order (not just bottom-up)+ - desugar node definitions (more robust, previously node definition handling was ad-hoc)+ - support qualified module imports+ - better tooltip ranges & types+ - bugfix: fix looping in type checking of recursive definitions+- compiler optimization+ - separate types and values (vs. church style lambda)+ - separate use of neutral terms+ - erease lambda variable type+ - erease univ. pol. arguments of constructors+ - erease univ. pol. arguments of case functions+ - speed up 'eval' function+ - tried to speedup with cache max. de bruin indices+ - use less 'try' in parser+- libraries+ - always put base library modules to include path+ - OpenGL API: simplify CullMode: remove FrontFace it is always ccw+ - OpenGL API: simplify Depth images handling+- testenv+ - language feature tests framework+- other+ - released on HackageDB+++# v0.3 - tagged on Jan 18, 2016++- compiler+ - complete rewrite from scratch+ - use De Bruijn indices instead of String names+ - pattern match compilation+ - compositional type inference is replaced by a zipper-based approach+ which plays better together with dependent types+- libraries/OpenGL API+ - interpolation handling is decoupled from vertex shader descriptions+ - introduce Stream data type; use just two types of streams instead of 4+- testenv+ - use Travis CI (continuous integration) with a docker image+ - timeout for tests+++# first DSL compiler - tagged on Jun 14, 2015++- supports a fair amount of Haskell98 language features+- partially supports GADTs and type families+- supports explicit type application+- supports row polymorphism and swizzling+- uses compositional typing for better error messages+- OpenGL API provided in attached Builtins and Prelude modules+- generates LambdaCube3D IR (intermediate representation)++
+ backendtest/EditorExamplesTest.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE LambdaCase #-}+module EditorExamplesTest (getRenderJob) where++import Control.Monad+import qualified Data.Vector as V+import qualified Data.Map as Map+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import Data.ByteString.Char8 (unpack)+import System.FilePath+import System.Directory++import Data.Aeson+import Data.Vect++import TestData as TD+import LambdaCube.Linear+import LambdaCube.IR+import LambdaCube.PipelineSchema+import LambdaCube.PipelineSchemaUtil+import LambdaCube.Mesh++import LambdaCube.Compiler as LambdaCube -- compiler++{-+ ../test-data/editor-examples++ let inputSchema = + { slots : fromArray [ Tuple "stream4" {primitive: Triangles, attributes: fromArray [Tuple "position4" TV4F, Tuple "vertexUV" TV2F]}+ ]+ , uniforms : fromArray+ +[ Tuple "MVP" M44F+ +, Tuple "Time" Float+ +, Tuple "Diffuse" FTexture2D+ ]+ }+-}++inputSchema = makeSchema $ do+ defObjectArray "stream4" Triangles $ do+ "position4" @: Attribute_V4F+ "vertexUV" @: Attribute_V2F+ defUniforms $ do+ "Time" @: Float+ "MVP" @: M44F+ "Diffuse" @: FTexture2D++frame t m = Frame+ { renderCount = 10+ , frameUniforms = Map.fromList [("Time",VFloat t), ("MVP",VM44F m)]+ , frameTextures = Map.fromList [("Diffuse",0)]+ }++scene wh = Scene+ { TD.objectArrays = Map.fromList [("stream4", V.fromList [0])]+ , renderTargetWidth = wh+ , renderTargetHeight = wh+ , frames = V.fromList [frame t (mvp t) | t <- [0..10]]+ }+ where+ mvp t =+ let camPos = Vec3 3.0 1.3 0.3+ camTarget = Vec3 0.0 0.0 0.0+ camUp = Vec3 0.0 1.0 0.0+ near = 0.1+ far = 100.0+ fovDeg = 30.0++ angle = pi / 24.0 * t++ cm = fromProjective $ lookat camPos camTarget camUp+ mm = fromProjective $ orthogonal $ toOrthoUnsafe $ rotMatrixY angle+ pm = perspective near far (fovDeg / 180 * pi) (fromIntegral wh / fromIntegral wh)+ in mat4ToM44F $ mm .*. cm .*. pm++getRenderJob = do+ let path = "./testdata/editor-examples"+ tests <- filter ((".lc" ==) . takeExtension) <$> getDirectoryContents path+ print tests+ ppls <- forM tests $ \name -> do+ putStrLn $ "compile: " ++ name+ LambdaCube.compileMain [path] OpenGL33 name >>= \case+ Left err -> fail $ "compile error:\n" ++ err+ Right ppl -> return $ PipelineInfo+ { pipelineName = path </> name+ , pipeline = ppl+ }++ img <- unpack . B64.encode <$> BS.readFile "./backend-test-data/editor/logo256x256.png"++ let job = RenderJob+ { meshes = V.fromList [cubeMesh]+ , TD.textures = V.fromList [img]+ , schema = inputSchema+ , scenes = V.fromList [scene 64]+ , pipelines = V.fromList ppls+ }+ return ("editor",job)++g_vertex_buffer_data =+ [ V4 1.0 1.0 (-1.0) 1.0+ , V4 1.0 (-1.0) (-1.0) 1.0+ , V4 (-1.0) (-1.0) (-1.0) 1.0++ , V4 1.0 1.0 (-1.0) 1.0+ , V4 (-1.0) (-1.0) (-1.0) 1.0+ , V4 (-1.0) 1.0 (-1.0) 1.0++ , V4 1.0 1.0 (-1.0) 1.0+ , V4 1.0 1.0 1.0 1.0+ , V4 1.0 (-1.0) 1.0 1.0++ , V4 1.0 1.0 (-1.0) 1.0+ , V4 1.0 (-1.0) 1.0 1.0+ , V4 1.0 (-1.0) (-1.0) 1.0++ , V4 1.0 1.0 1.0 1.0+ , V4 (-1.0) (-1.0) 1.0 1.0+ , V4 1.0 (-1.0) 1.0 1.0++ , V4 1.0 1.0 1.0 1.0+ , V4 (-1.0) 1.0 1.0 1.0+ , V4 (-1.0) (-1.0) 1.0 1.0++ , V4 (-1.0) 1.0 1.0 1.0+ , V4 (-1.0) (-1.0) (-1.0) 1.0+ , V4 (-1.0) (-1.0) 1.0 1.0++ , V4 (-1.0) 1.0 1.0 1.0+ , V4 (-1.0) 1.0 (-1.0) 1.0+ , V4 (-1.0) (-1.0) (-1.0) 1.0++ , V4 1.0 1.0 (-1.0) 1.0+ , V4 (-1.0) 1.0 (-1.0) 1.0+ , V4 (-1.0) 1.0 1.0 1.0++ , V4 1.0 1.0 (-1.0) 1.0+ , V4 (-1.0) 1.0 1.0 1.0+ , V4 1.0 1.0 1.0 1.0++ , V4 1.0 (-1.0) (-1.0) 1.0+ , V4 1.0 (-1.0) 1.0 1.0+ , V4 (-1.0) (-1.0) 1.0 1.0++ , V4 1.0 (-1.0) (-1.0) 1.0+ , V4 (-1.0) (-1.0) 1.0 1.0+ , V4 (-1.0) (-1.0) (-1.0) 1.0+ ]++-- Two UV coordinatesfor each vertex. They were created with Blender.+g_uv_buffer_data =+ [ V2 0.0 1.0+ , V2 0.0 0.0+ , V2 1.0 0.0+ , V2 0.0 1.0+ , V2 1.0 0.0+ , V2 1.0 1.0+ , V2 0.0 1.0+ , V2 1.0 1.0+ , V2 1.0 0.0+ , V2 0.0 1.0+ , V2 1.0 0.0+ , V2 0.0 0.0+ , V2 1.0 1.0+ , V2 0.0 0.0+ , V2 1.0 0.0+ , V2 1.0 1.0+ , V2 0.0 1.0+ , V2 0.0 0.0+ , V2 0.0 1.0+ , V2 1.0 0.0+ , V2 0.0 0.0+ , V2 0.0 1.0+ , V2 1.0 1.0+ , V2 1.0 0.0+ , V2 0.0 1.0+ , V2 1.0 1.0+ , V2 1.0 0.0+ , V2 0.0 1.0+ , V2 1.0 0.0+ , V2 0.0 0.0+ , V2 0.0 1.0+ , V2 0.0 0.0+ , V2 1.0 0.0+ , V2 0.0 1.0+ , V2 1.0 0.0+ , V2 1.0 1.0+ ]++cubeMesh = Mesh+ { mAttributes = Map.fromList+ [ ("position4", A_V4F $ V.fromList g_vertex_buffer_data)+ , ("vertexUV", A_V2F $ V.fromList g_uv_buffer_data)+ ]+ , mPrimitive = P_Triangles+ }++vec4ToV4F (Vec4 x y z w) = V4 x y z w+mat4ToM44F (Mat4 a b c d) = V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)++-- | Camera transformation matrix.+lookat :: Vec3 -- ^ Camera position.+ -> Vec3 -- ^ Target position.+ -> Vec3 -- ^ Upward direction.+ -> Proj4+lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)+ where+ w = normalize $ pos &- target+ u = normalize $ up &^ w+ v = w &^ u+ r = transpose $ Mat3 u v w++-- | Perspective transformation matrix in row major order.+perspective :: Float -- ^ Near plane clipping distance (always positive).+ -> Float -- ^ Far plane clipping distance (always positive).+ -> Float -- ^ Field of view of the y axis, in radians.+ -> Float -- ^ Aspect ratio, i.e. screen's width\/height.+ -> Mat4+perspective n f fovy aspect = transpose $+ Mat4 (Vec4 (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)+ (Vec4 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)+ (Vec4 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))+ (Vec4 0 0 (-1) 0)+ where+ t = n*tan(fovy/2)+ b = -t+ r = aspect*t+ l = -r
+ backendtest/TestData.hs view
@@ -0,0 +1,242 @@+-- generated file, do not modify!+-- 2016-02-12T16:05:13.383716000000Z++{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+module TestData where++import Data.Int+import Data.Word+import Data.Map+import Data.Vector (Vector(..))+import LambdaCube.Linear++import Data.Text+import Data.Aeson hiding (Value,Bool)+import Data.Aeson.Types hiding (Value,Bool)+import Control.Monad++import LambdaCube.IR+import LambdaCube.Mesh+import LambdaCube.PipelineSchema++data ClientInfo+ = ClientInfo+ { clientName :: String+ , clientBackend :: Backend+ }++ deriving (Show, Eq, Ord)++data Frame+ = Frame+ { renderCount :: Int+ , frameUniforms :: Map String Value+ , frameTextures :: Map String Int+ }++ deriving (Show, Eq, Ord)++data Scene+ = Scene+ { objectArrays :: Map String (Vector Int)+ , renderTargetWidth :: Int+ , renderTargetHeight :: Int+ , frames :: Vector Frame+ }++ deriving (Show, Eq, Ord)++data PipelineInfo+ = PipelineInfo+ { pipelineName :: String+ , pipeline :: Pipeline+ }++ deriving (Show, Eq, Ord)++data RenderJob+ = RenderJob+ { meshes :: Vector Mesh+ , textures :: Vector String+ , schema :: PipelineSchema+ , scenes :: Vector Scene+ , pipelines :: Vector PipelineInfo+ }++ deriving (Show, Eq, Ord)++data FrameResult+ = FrameResult+ { frRenderTimes :: Vector Float+ , frImageWidth :: Int+ , frImageHeight :: Int+ }++ deriving (Show, Eq, Ord)++data RenderJobResult+ = RenderJobResult FrameResult+ | RenderJobError String+ deriving (Show, Eq, Ord)+++instance ToJSON ClientInfo where+ toJSON v = case v of+ ClientInfo{..} -> object+ [ "tag" .= ("ClientInfo" :: Text)+ , "clientName" .= clientName+ , "clientBackend" .= clientBackend+ ]++instance FromJSON ClientInfo where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "ClientInfo" -> do+ clientName <- obj .: "clientName"+ clientBackend <- obj .: "clientBackend"+ pure $ ClientInfo+ { clientName = clientName+ , clientBackend = clientBackend+ } + parseJSON _ = mzero++instance ToJSON Frame where+ toJSON v = case v of+ Frame{..} -> object+ [ "tag" .= ("Frame" :: Text)+ , "renderCount" .= renderCount+ , "frameUniforms" .= frameUniforms+ , "frameTextures" .= frameTextures+ ]++instance FromJSON Frame where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "Frame" -> do+ renderCount <- obj .: "renderCount"+ frameUniforms <- obj .: "frameUniforms"+ frameTextures <- obj .: "frameTextures"+ pure $ Frame+ { renderCount = renderCount+ , frameUniforms = frameUniforms+ , frameTextures = frameTextures+ } + parseJSON _ = mzero++instance ToJSON Scene where+ toJSON v = case v of+ Scene{..} -> object+ [ "tag" .= ("Scene" :: Text)+ , "objectArrays" .= objectArrays+ , "renderTargetWidth" .= renderTargetWidth+ , "renderTargetHeight" .= renderTargetHeight+ , "frames" .= frames+ ]++instance FromJSON Scene where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "Scene" -> do+ objectArrays <- obj .: "objectArrays"+ renderTargetWidth <- obj .: "renderTargetWidth"+ renderTargetHeight <- obj .: "renderTargetHeight"+ frames <- obj .: "frames"+ pure $ Scene+ { objectArrays = objectArrays+ , renderTargetWidth = renderTargetWidth+ , renderTargetHeight = renderTargetHeight+ , frames = frames+ } + parseJSON _ = mzero++instance ToJSON PipelineInfo where+ toJSON v = case v of+ PipelineInfo{..} -> object+ [ "tag" .= ("PipelineInfo" :: Text)+ , "pipelineName" .= pipelineName+ , "pipeline" .= pipeline+ ]++instance FromJSON PipelineInfo where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "PipelineInfo" -> do+ pipelineName <- obj .: "pipelineName"+ pipeline <- obj .: "pipeline"+ pure $ PipelineInfo+ { pipelineName = pipelineName+ , pipeline = pipeline+ } + parseJSON _ = mzero++instance ToJSON RenderJob where+ toJSON v = case v of+ RenderJob{..} -> object+ [ "tag" .= ("RenderJob" :: Text)+ , "meshes" .= meshes+ , "textures" .= textures+ , "schema" .= schema+ , "scenes" .= scenes+ , "pipelines" .= pipelines+ ]++instance FromJSON RenderJob where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "RenderJob" -> do+ meshes <- obj .: "meshes"+ textures <- obj .: "textures"+ schema <- obj .: "schema"+ scenes <- obj .: "scenes"+ pipelines <- obj .: "pipelines"+ pure $ RenderJob+ { meshes = meshes+ , textures = textures+ , schema = schema+ , scenes = scenes+ , pipelines = pipelines+ } + parseJSON _ = mzero++instance ToJSON FrameResult where+ toJSON v = case v of+ FrameResult{..} -> object+ [ "tag" .= ("FrameResult" :: Text)+ , "frRenderTimes" .= frRenderTimes+ , "frImageWidth" .= frImageWidth+ , "frImageHeight" .= frImageHeight+ ]++instance FromJSON FrameResult where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "FrameResult" -> do+ frRenderTimes <- obj .: "frRenderTimes"+ frImageWidth <- obj .: "frImageWidth"+ frImageHeight <- obj .: "frImageHeight"+ pure $ FrameResult+ { frRenderTimes = frRenderTimes+ , frImageWidth = frImageWidth+ , frImageHeight = frImageHeight+ } + parseJSON _ = mzero++instance ToJSON RenderJobResult where+ toJSON v = case v of+ RenderJobResult arg0 -> object [ "tag" .= ("RenderJobResult" :: Text), "arg0" .= arg0]+ RenderJobError arg0 -> object [ "tag" .= ("RenderJobError" :: Text), "arg0" .= arg0]++instance FromJSON RenderJobResult where+ parseJSON (Object obj) = do+ tag <- obj .: "tag"+ case tag :: Text of+ "RenderJobResult" -> RenderJobResult <$> obj .: "arg0"+ "RenderJobError" -> RenderJobError <$> obj .: "arg0"+ parseJSON _ = mzero+
+ backendtest/TestServer.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings, LambdaCase, RecordWildCards #-}+import Control.Monad+import Control.Concurrent+import Control.Exception (finally)+import Data.Aeson+import Foreign+import Codec.Picture as Juicy+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import Data.ByteString.Char8 (unpack)+import qualified Data.Vector as V+import qualified Data.Vector.Storable as SV+import qualified Network.WebSockets as WS+import qualified Data.Map as Map+import Text.Printf+import System.FilePath+import System.Directory+import System.Process++import TestData+import LambdaCube.Linear+import LambdaCube.IR+import LambdaCube.PipelineSchema+import LambdaCube.PipelineSchemaUtil+import LambdaCube.Mesh++import qualified EditorExamplesTest++main :: IO ()+main = do+ putStrLn "listening"+ WS.runServer "192.168.0.12" 9160 application++application pending = do+ conn <- WS.acceptRequest pending+ WS.forkPingThread conn 30+ let disconnect = return ()+ one = 1 :: Int+ flip finally disconnect $ do+ -- receive client info+ decodeStrict <$> WS.receiveData conn >>= \case+ Nothing -> fail "invalid client info"+ Just ci@ClientInfo{..} -> print ci+ -- send pipeline+ (testName,renderJob@RenderJob{..}) <- EditorExamplesTest.getRenderJob -- TODO+ WS.sendTextData conn . encode $ renderJob+ -- get render result: pipeline x scene x frame+ res <- forM pipelines $ \PipelineInfo{..} -> do+ forM (zip [one..] $ V.toList scenes) $ \(sIdx,Scene{..}) ->+ forM [one..length frames] $ \fIdx -> do+ let name = "backend-test-data/" ++ testName ++ "/result/" ++ takeBaseName pipelineName ++ "_scn" ++ printf "%02d" sIdx ++ "_" ++ printf "%02d" fIdx ++ ".png"+ decodeStrict <$> WS.receiveData conn >>= \case+ Nothing -> fail $ name ++ " - invalid RenderJobResult"+ Just (RenderJobError e) -> fail $ name ++ " - render error:\n" ++ e -- TODO: test failed+ Just (RenderJobResult FrameResult{..}) -> do+ createDirectoryIfMissing True (takeDirectory name)+ compareOrSaveImage name =<< toImage frImageWidth frImageHeight . either error id . B64.decode =<< WS.receiveData conn+ --putStrLn $ name ++ "\t" ++ unwords (map showTime . V.toList $ frRenderTimes)+ let differ = or $ concat $ fmap concat res+ putStrLn $ "render job: " ++ if differ then "FAIL" else "OK"+ forever $ threadDelay 1000000++compareOrSaveImage name img@(Image w h pixels) = do+ doesFileExist name >>= \case+ False -> do+ putStrLn $ "new image: " ++ name+ savePngImage name (ImageRGBA8 img)+ return False+ True -> do+ Right (ImageRGBA8 (Image origW origH origPixels)) <- readImage name+ let diffPixels a b = SV.sum $ SV.zipWith (\x y -> (fromIntegral x - fromIntegral y)^2) a b :: Float+ diff = diffPixels pixels origPixels+ threshold = 0+ differ = w /= origW || h /= origH || diff > threshold+ case differ of+ True -> do+ putStrLn $ name ++ " - differ!!! " ++ show diff+ let mismatchImage = dropExtension name ++ "_mismatch.png"+ diffImage = dropExtension name ++ "_diff.png"+ putStrLn $ "save difference: " ++ diffImage+ savePngImage mismatchImage (ImageRGBA8 img)+ (exitCode,out,err) <- readProcessWithExitCode "compare" ["-compose","src",name,mismatchImage,diffImage] ""+ --let res = read . head . words $ out :: Float+ print (out,err)+ False -> putStrLn $ name ++ " OK"+ return differ++toImage :: Int -> Int -> BS.ByteString -> IO (Image PixelRGBA8)+toImage w h buf = do+ fp <- mallocForeignPtrBytes (4*w*h)+ withForeignPtr fp $ \dst -> BS.useAsCStringLen buf $ \(src,i) -> copyBytes dst (castPtr src) i+ return $ Image w h $ SV.unsafeFromForeignPtr fp 0 (w*h)++showTime delta+ | t > 1e-1 = printf "%.3fs" t+ | t > 1e-3 = printf "%.1fms" (t/1e-3)+ | otherwise = printf "%.0fus" (t/1e-6)+ where+ t = realToFrac delta :: Double++{-+ data sets:+ hello+ editor+-}+{-+ features to test:+ blending+ depth test+ culling+ texturing+ uniform texture+ render texture+ multi draw calls into the same framebuffer+-}+-- TODO+{-+ how to pair pipelines with predefined data+ basically: storage - pipelines+ render job:+ gpu data+ scene <--> storage+ frame+-}+{-+ initial test cases:+ - hello - done+ - editor exercises+ TODO+ create storage+ collect pipelines+ - create render job list+-}
lambdacube-compiler.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: lambdacube-compiler-version: 0.4.0.1+version: 0.5.0.0 homepage: http://lambdacube3d.com synopsis: LambdaCube 3D is a DSL to program GPUs description: LambdaCube 3D is a domain specific language and library that makes it@@ -14,6 +14,7 @@ category: Graphics, Compiler build-type: Simple cabal-version: >=1.10+extra-source-files: CHANGELOG.md Data-Files: lc/Builtins.lc@@ -77,12 +78,11 @@ exceptions >= 0.8 && <0.9, filepath, mtl >=2.2 && <2.3,- parsec >= 3.1.9 && <3.2,--- megaparsec >= 4.3.0 && <4.4,- indentation >= 0.2 && <0.3,- pretty-compact >=1.0 && <1.1,+ megaparsec >= 4.3.0 && <4.4,+ wl-pprint >=1.2 && <1.3,+ pretty-show >= 1.6.9, text >= 1.2 && <1.3,- lambdacube-ir == 0.2.*,+ lambdacube-ir == 0.3.*, vector >= 0.11 && <0.12 hs-source-dirs: src@@ -102,7 +102,7 @@ base < 4.9, containers >=0.5 && <0.6, lambdacube-compiler,- parsec >= 3.1.9 && <3.2,+ megaparsec >= 4.3.0 && <4.4, QuickCheck >= 2.8.2 && <2.9, tasty >= 0.11 && <0.12, tasty-quickcheck >=0.8 && <0.9@@ -131,18 +131,33 @@ mtl >=2.2 && <2.3, monad-control >= 1.0 && <1.1, optparse-applicative == 0.12.*,- parsec >= 3.1.9 && <3.2,- indentation >= 0.2 && <0.3,- pretty-compact >=1.0 && <1.1,+ megaparsec >= 4.3.0 && <4.4,+ wl-pprint >=1.2 && <1.3,+ patience >= 0.1 && < 0.2, text >= 1.2 && <1.3, time >= 1.5 && <1.6,- lambdacube-ir == 0.2.*,+ lambdacube-ir == 0.3.*, vector >= 0.11 && <0.12 if flag(profiling) GHC-Options: -fprof-auto -rtsopts+ else+ GHC-Options: -rtsopts +executable lambdacube-compiler-performance-report+ hs-source-dirs: test+ main-is: PerfReport.hs+ default-language: Haskell2010 + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository+ build-depends:+ base < 4.9,+ directory,+ filepath,+ containers >=0.5 && <0.6,+ optparse-applicative == 0.12.*++ executable lc hs-source-dirs: tool main-is: Compiler.hs@@ -153,7 +168,7 @@ base < 4.9, lambdacube-compiler, optparse-applicative == 0.12.*,- aeson >= 0.9 && < 0.11,+ aeson >= 0.9 && <1, bytestring == 0.10.*, filepath == 1.4.* @@ -162,7 +177,39 @@ else Buildable: True +executable lambdacube-backend-test-server+ hs-source-dirs: backendtest+ main-is: TestServer.hs+ default-language: Haskell2010+ other-modules: EditorExamplesTest+ TestData + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository+ build-depends:+ base < 4.9,+ containers >=0.5 && <0.6,+ text >= 1.2 && <1.3,+ lambdacube-compiler,+ lambdacube-ir == 0.3.*,+ pretty-show >= 1.6.9,+ optparse-applicative == 0.12.*,+ aeson >= 0.9 && <1,+ bytestring == 0.10.*,+ filepath == 1.4.*,+ directory,+ websockets >= 0.9.6.1,+ JuicyPixels >=3.2.7 && <3.3,+ vect >= 0.4.7,+ base64-bytestring >= 1.0.0.1,+ vector >= 0.11 && <0.12,+ process >= 1.2++ if flag(onlytestsuite)+ Buildable: False+ else+ Buildable: True++ executable lambdacube-compiler-coverage-test-suite hs-source-dirs: src, test main-is: runTests.hs@@ -188,13 +235,14 @@ directory, exceptions >= 0.8 && <0.9, filepath,- lambdacube-ir == 0.2.*,+ lambdacube-ir == 0.3.*, mtl >=2.2 && <2.3, monad-control >= 1.0 && <1.1, optparse-applicative == 0.12.*,- parsec >= 3.1.9 && <3.2,- indentation >= 0.2 && <0.3,- pretty-compact >=1.0 && <1.1,+ megaparsec >= 4.3.0 && <4.4,+ wl-pprint >=1.2 && <1.3,+ pretty-show >= 1.6.9,+ patience >= 0.1 && < 0.2, text >= 1.2 && <1.3, time >= 1.5 && <1.6, vector >= 0.11 && <0.12
lc/Builtins.lc view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+ module Builtins ( module Internals , module Builtins@@ -10,28 +11,23 @@ --------------------------------------- -class AttributeTuple a-instance AttributeTuple a -- TODO-class ValidOutput a-instance ValidOutput a -- TODO-class ValidFrameBuffer a-instance ValidFrameBuffer a -- TODO- data VecS (a :: Type) :: Nat -> Type where V2 :: a -> a -> VecS a 2 V3 :: a -> a -> a -> VecS a 3 V4 :: a -> a -> a -> a -> VecS a 4 +mapVec :: (a -> b) -> VecS a n -> VecS b n+mapVec f (V2 x y) = V2 (f x) (f y)+mapVec f (V3 x y z) = V3 (f x) (f y) (f z)+mapVec f (V4 x y z w) = V4 (f x) (f y) (f z) (f w)+ type family Vec (n :: Nat) t where Vec n t = VecS t n +-- type family VecScalar (n :: Nat) a = r | r -> n, r -> a where type family VecScalar (n :: Nat) a where VecScalar 1 a = a VecScalar ('Succ ('Succ n)) a = Vec ('Succ ('Succ n)) a --- may be a data family?-type family TFVec (n :: Nat) a where- TFVec n a = Vec n a -- TODO: check range: n = 2,3,4; a is Float, Int, Word, Bool- -- todo: use less constructors with more parameters data Mat :: Nat -> Nat -> Type -> Type where M22F :: Vec 2 Float -> Vec 2 Float -> Mat 2 2 Float@@ -51,41 +47,6 @@ MatVecScalarElem (VecS a n) = a MatVecScalarElem (Mat i j a) = a ---------------------------------------- swizzling--data Swizz = Sx | Sy | Sz | Sw---- todo: use pattern matching-mapVec :: forall a b m . (a -> b) -> Vec m a -> Vec m b-mapVec @a @b @m f v = 'VecSCase (\m _ -> 'Vec m b)- (\x y -> V2 (f x) (f y))- (\x y z -> V3 (f x) (f y) (f z))- (\x y z w -> V4 (f x) (f y) (f z) (f w))- @m- v---- todo: make it more type safe-swizzscalar :: forall n . Vec n a -> Swizz -> a-swizzscalar (V2 x y) Sx = x-swizzscalar (V2 x y) Sy = y-swizzscalar (V3 x y z) Sx = x-swizzscalar (V3 x y z) Sy = y-swizzscalar (V3 x y z) Sz = z-swizzscalar (V4 x y z w) Sx = x-swizzscalar (V4 x y z w) Sy = y-swizzscalar (V4 x y z w) Sz = z-swizzscalar (V4 x y z w) Sw = w---- used to prevent unfolding of swizzvector on variables (behind GPU lambda)-definedVec :: forall a m . Vec m a -> Bool-definedVec (V2 _ _) = True-definedVec (V3 _ _ _) = True-definedVec (V4 _ _ _ _) = True--swizzvector :: forall n . forall m . Vec n a -> Vec m Swizz -> Vec m a-swizzvector v w | definedVec v = mapVec (swizzscalar v) w-- --------------------------------------- type classes class Signed a@@ -94,39 +55,39 @@ instance Signed Float class Component a where- zeroComp :: a- oneComp :: a+ zero :: a+ one :: a instance Component Int where- zeroComp = 0 :: Int- oneComp = 1 :: Int+ zero = 0 :: Int+ one = 1 :: Int instance Component Word where- zeroComp = 0 :: Word- oneComp = 1 :: Word+ zero = 0 :: Word+ one = 1 :: Word instance Component Float where- zeroComp = 0.0- oneComp = 1.0+ zero = 0.0+ one = 1.0 instance Component (VecS Float 2) where- zeroComp = V2 0.0 0.0- oneComp = V2 1.0 1.0+ zero = V2 0.0 0.0+ one = V2 1.0 1.0 instance Component (VecS Float 3) where- zeroComp = V3 0.0 0.0 0.0- oneComp = V3 1.0 1.0 1.0+ zero = V3 0.0 0.0 0.0+ one = V3 1.0 1.0 1.0 instance Component (VecS Float 4) where- zeroComp = V4 0.0 0.0 0.0 0.0- oneComp = V4 1.0 1.0 1.0 1.0+ zero = V4 0.0 0.0 0.0 0.0+ one = V4 1.0 1.0 1.0 1.0 instance Component Bool where- zeroComp = False- oneComp = True+ zero = False+ one = True instance Component (VecS Bool 2) where- zeroComp = V2 False False- oneComp = V2 True True+ zero = V2 False False+ one = V2 True True instance Component (VecS Bool 3) where- zeroComp = V3 False False False- oneComp = V3 True True True+ zero = V3 False False False+ one = V3 True True True instance Component (VecS Bool 4) where- zeroComp = V4 False False False False- oneComp = V4 True True True True+ zero = V4 False False False False+ one = V4 True True True True class Integral a @@ -149,9 +110,257 @@ instance Floating (Mat 4 3 Float) instance Floating (Mat 4 4 Float) ++-------------------------------------------------------------------+-- * Builtin Primitive Functions *+-- Arithmetic Functions (componentwise)++PrimAdd, PrimSub, PrimMul :: Num (MatVecScalarElem a) => a -> a -> a+PrimAddS, PrimSubS, PrimMulS :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a+PrimDiv, PrimMod :: (Num t, a ~ VecScalar d t) => a -> a -> a+PrimDivS, PrimModS :: (Num t, a ~ VecScalar d t) => a -> t -> a+PrimNeg :: Signed (MatVecScalarElem a) => a -> a+-- Bit-wise Functions+PrimBAnd, PrimBOr, PrimBXor :: (Integral t, a ~ VecScalar d t) => a -> a -> a+PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a+PrimBNot :: (Integral t, a ~ VecScalar d t) => a -> a+PrimBShiftL, PrimBShiftR :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a+PrimBShiftLS, PrimBShiftRS :: (Integral t, a ~ VecScalar d t) => a -> Word -> a+-- Logic Functions+PrimAnd, PrimOr, PrimXor :: Bool -> Bool -> Bool+PrimNot :: forall a d . (a ~ VecScalar d Bool) => a -> a+PrimAny, PrimAll :: VecScalar d Bool -> Bool++-- Angle, Trigonometry and Exponential Functions+PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt+ :: (a ~ VecScalar d Float) => a -> a+PrimPow, PrimATan2 :: (a ~ VecScalar d Float) => a -> a -> a+-- Common Functions+PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract+ :: (a ~ VecScalar d Float) => a -> a+PrimMin, PrimMax :: (Num t, a ~ VecScalar d t) => a -> a -> a+PrimMinS, PrimMaxS :: (Num t, a ~ VecScalar d t) => a -> t -> a+PrimIsNan, PrimIsInf :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b+PrimAbs, PrimSign :: (Signed t, a ~ VecScalar d t) => a -> a+PrimModF :: (a ~ VecScalar d Float) => a -> (a, a)+PrimClamp :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a+PrimClampS :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a+PrimMix :: (a ~ VecScalar d Float) => a -> a -> a -> a+PrimMixS :: (a ~ VecScalar d Float) => a -> a -> Float -> a+PrimMixB :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> a -> b -> a+PrimStep :: (a ~ Vec d Float) => a -> a -> a+PrimStepS :: (a ~ VecScalar d Float) => Float -> a -> a+PrimSmoothStep :: (a ~ Vec d Float) => a -> a -> a -> a+PrimSmoothStepS :: (a ~ VecScalar d Float) => Float -> Float -> a -> a++-- Integer/Floatonversion Functions+PrimFloatBitsToInt :: VecScalar d Float -> VecScalar d Int+PrimFloatBitsToUInt :: VecScalar d Float -> VecScalar d Word+PrimIntBitsToFloat :: VecScalar d Int -> VecScalar d Float+PrimUIntBitsToFloat :: VecScalar d Word -> VecScalar d Float+-- Geometric Functions+PrimLength :: (a ~ VecScalar d Float) => a -> Float+PrimDistance, PrimDot :: (a ~ VecScalar d Float) => a -> a -> Float+PrimCross :: (a ~ VecScalar 3 Float) => a -> a -> a+PrimNormalize :: (a ~ VecScalar d Float) => a -> a+PrimFaceForward, PrimRefract :: (a ~ VecScalar d Float) => a -> a -> a -> a+PrimReflect :: (a ~ VecScalar d Float) => a -> a -> a+-- Matrix Functions+PrimTranspose :: Mat h w a -> Mat w h a+PrimDeterminant :: Mat s s a -> Float+PrimInverse :: Mat s s a -> Mat s s a+PrimOuterProduct :: Vec w a -> Vec h a -> Mat h w a+PrimMulMatVec :: Mat h w a -> Vec w a -> Vec h a+PrimMulVecMat :: Vec h a -> Mat h w a -> Vec w a+PrimMulMatMat :: Mat i j a -> Mat j k a -> Mat i k a+-- Vector and Scalar Relational Functions+PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV+ :: forall a d t b . (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b+PrimEqual, PrimNotEqual :: forall a t . (t ~ MatVecScalarElem a) => a -> a -> Bool+-- Fragment Processing Functions+PrimDFdx, PrimDFdy, PrimFWidth+ :: (a ~ VecScalar d Float) => a -> a+-- Noise Functions+PrimNoise1 :: VecScalar d Float -> Float+PrimNoise2 :: VecScalar d Float -> Vec 2 Float+PrimNoise3 :: VecScalar d Float -> Vec 3 Float+PrimNoise4 :: VecScalar d Float -> Vec 4 Float++{-+-- Vec/Mat (de)construction+PrimTupToV2 :: Component a => PrimFun stage ((a,a) -> V2 a)+PrimTupToV3 :: Component a => PrimFun stage ((a,a,a) -> V3 a)+PrimTupToV4 :: Component a => PrimFun stage ((a,a,a,a) -> V4 a)+PrimV2ToTup :: Component a => PrimFun stage (V2 a -> (a,a))+PrimV3ToTup :: Component a => PrimFun stage (V3 a -> (a,a,a))+PrimV4ToTup :: Component a => PrimFun stage (V4 a -> (a,a,a,a))+-}++-------------------------------------------------------++head (x: _) = x++[] ++ ys = ys+x:xs ++ ys = x : xs ++ ys++foldr f e [] = e+foldr f e (x: xs) = f x (foldr f e xs)++concat = foldr (++) []++map _ [] = []+map f (x:xs) = f x : map f xs++concatMap :: (a -> [b]) -> [a] -> [b]+concatMap f x = concat (map f x)++len [] = 0+len (x:xs) = 1 `primAddInt` len xs++-------------------++data Maybe a+ = Nothing+ | Just a+-- deriving (Eq, Ord, Show)++data Vector (n :: Nat) t++-------------------------------------------------------++data PrimitiveType+ = Triangle+ | Line+ | Point+ | TriangleAdjacency+ | LineAdjacency++data Primitive a :: PrimitiveType -> Type where+ PrimPoint :: a -> Primitive a Point+ PrimLine :: a -> a -> Primitive a Line+ PrimTriangle :: a -> a -> a -> Primitive a Triangle++mapPrimitive :: (a -> b) -> Primitive a p -> Primitive b p+{- todo+mapPrimitive f (PrimPoint a) = PrimPoint (f a)+mapPrimitive f (PrimLine a b) = PrimLine (f a) (f b)+mapPrimitive f (PrimTriangle a b c) = PrimTriangle (f a) (f b) (f c)+-}++type PrimitiveStream a t = [Primitive t a]++mapPrimitives :: (a -> b) -> PrimitiveStream p a -> PrimitiveStream p b+mapPrimitives f = map (mapPrimitive f)++type family ListElem a where ListElem [a] = a++--class AttributeTuple a+--instance AttributeTuple a -- TODO++fetchArrays :: forall a t t' . ({-AttributeTuple t, -} t ~ map ListElem t') => HList t' -> PrimitiveStream a (HList t)++fetch :: forall a t . {-(AttributeTuple t) => -} String -> HList t -> PrimitiveStream a (HList t)++Attribute :: String -> t++fetchStream :: forall p (t :: [Type]) . String -> forall (as :: [String]) -> len as ~ len t => PrimitiveStream p (HList t)++------------------------------------------------------++type Fragment n t = Vector n (Maybe (SimpleFragment t))++data SimpleFragment t = SimpleFragment+ { sFragmentCoords :: Vec 3 Float+ , sFragmentValue :: t+ }++type FragmentStream n t = [Fragment n t]++customizeDepth :: (a -> Float) -> Fragment n a -> Fragment n a++customizeDepths :: (a -> Float) -> FragmentStream n a -> FragmentStream n a+customizeDepths f = map (customizeDepth f)++filterFragment :: (a -> Bool) -> Fragment n a -> Fragment n a++filterFragments :: (a -> Bool) -> FragmentStream n a -> FragmentStream n a+filterFragments p = map (filterFragment p)++mapFragment :: (a -> b) -> Fragment n a -> Fragment n b++mapFragments :: (a -> b) -> FragmentStream n a -> FragmentStream n b+mapFragments f = map (mapFragment f)++-------------------------------------------------------------------------++data ImageKind+ = Color Type+ | Depth+ | Stencil++imageType :: ImageKind -> Type+imageType (Color a) = a+imageType Depth = 'Float+imageType Stencil = 'Int++data Image (n :: Nat) (t :: ImageKind) -- = Vector n [[imageType t]]++ColorImage :: forall a d t color . (Num t, color ~ VecScalar d t)+ => color -> Image a (Color color)+DepthImage :: forall a . Float -> Image a Depth+StencilImage :: forall a . Int -> Image a Stencil++emptyDepthImage = DepthImage @1+emptyColorImage = ColorImage @1++-------------------------------------------------------------------------+++--------------------------------------- swizzling++data Swizz = Sx | Sy | Sz | Sw+{-+data Swizz' :: Nat -> Type where+ Sx' :: forall n . Swizz' (Succ n)+ Sy' :: forall n . Swizz' (Succ (Succ n))+ Sz' :: forall n . Swizz' (Succ (Succ (Succ n)))+ Sw' :: forall n . Swizz' (Succ (Succ (Succ (Succ n))))++swizzscalar' :: forall n -> Vec n a -> Swizz' n -> a+swizzscalar' 2 = \x -> case x of+ V2 x y -> \s -> case s of+ Sx' -> x+ Sy' -> y+swizzscalar' 3 = \x -> case x of+ V3 x y z -> \s -> case s of+ Sx' -> x+-}+-- todo: make it more type safe+swizzscalar :: forall n . Vec n a -> Swizz -> a+swizzscalar (V2 x y) Sx = x+swizzscalar (V2 x y) Sy = y+swizzscalar (V3 x y z) Sx = x+swizzscalar (V3 x y z) Sy = y+swizzscalar (V3 x y z) Sz = z+swizzscalar (V4 x y z w) Sx = x+swizzscalar (V4 x y z w) Sy = y+swizzscalar (V4 x y z w) Sz = z+swizzscalar (V4 x y z w) Sw = w++-- used to prevent unfolding of swizzvector on variables (behind GPU lambda)+definedVec :: forall a m . Vec m a -> Bool+definedVec (V2 _ _) = True+definedVec (V3 _ _ _) = True+definedVec (V4 _ _ _ _) = True++swizzvector :: forall n . forall m . Vec n a -> Vec m Swizz -> Vec m a+swizzvector v w | definedVec v = mapVec (swizzscalar v) w++-----------------------------------------------------------------------------+ data BlendingFactor- = Zero' --- FIXME: modified- | One+ = ZeroBF+ | OneBF | SrcColor | OneMinusSrcColor | DstColor@@ -237,35 +446,17 @@ = LowerLeft | UpperLeft --data Depth a where-data Stencil a where-data Color a where--data PrimitiveType- = Triangle- | Line- | Point- | TriangleAdjacency- | LineAdjacency- -- builtin primTexture :: () -> Vec 2 Float -> Vec 4 Float -- builtins Uniform :: String -> t-Attribute :: String -> t data RasterContext a :: PrimitiveType -> Type where TriangleCtx :: CullMode -> PolygonMode a -> PolygonOffset -> ProvokingVertex -> RasterContext a Triangle PointCtx :: PointSize a -> Float -> PointSpriteCoordOrigin -> RasterContext a Point LineCtx :: Float -> ProvokingVertex -> RasterContext a Line -type family FTRepr' a where- -- TODO- FTRepr' [a] = a- FTRepr' ([a], [b]) = (a, b)- data Blending :: Type -> Type where NoBlending :: Blending t BlendLogicOp :: (Integral t) => LogicOperation -> Blending t@@ -273,267 +464,84 @@ -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor)) -> Vec 4 Float -> Blending Float -{- TODO: more precise kinds- FragmentOperation :: Semantic -> *- FragmentOut :: Semantic -> *--}- data StencilTests data StencilOps-data Int32 -data FragmentOperation :: Type -> Type where- ColorOp :: (mask ~ VecScalar d Bool, color ~ VecScalar d c, Num c) => Blending c -> mask- -> FragmentOperation (Color color)- DepthOp :: ComparisonFunction -> Bool -> FragmentOperation (Depth Float)- StencilOp :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation (Stencil Int32)-{--type family FragOps a where- FragOps (FragmentOperation t) = t- FragOps (FragmentOperation t1, FragmentOperation t2) = (t1, t2)- FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3) = (t1, t2, t3)- FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4) = (t1, t2, t3, t4)- FragOps (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4, FragmentOperation t5) = (t1, t2, t3, t4, t5)--}-type family FragOps a where- FragOps (t1, t2) = (FragmentOperation t1, FragmentOperation t2)- FragOps (t1, t2, t3) = (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3)- FragOps (t1, t2, t3, t4) = (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4)- FragOps (t1, t2, t3, t4, t5) = (FragmentOperation t1, FragmentOperation t2, FragmentOperation t3, FragmentOperation t4, FragmentOperation t5)- FragOps t = (FragmentOperation t)--[] ++ ys = ys-x:xs ++ ys = x : xs ++ ys--foldr f e [] = e-foldr f e (x: xs) = f x (foldr f e xs)--concat = foldr (++) []--map _ [] = []-map f (x:xs) = f x : map f xs--concatMap :: (a -> [b]) -> [a] -> [b]-concatMap f x = concat (map f x)--data Primitive a :: PrimitiveType -> Type where- PrimPoint :: a -> Primitive a Point- PrimLine :: a -> a -> Primitive a Line- PrimTriangle :: a -> a -> a -> Primitive a Triangle--type PrimitiveStream a t = [Primitive t a]--mapPrimitive :: (a -> b) -> Primitive a p -> Primitive b p-{- todo-mapPrimitive f (PrimPoint a) = PrimPoint (f a)-mapPrimitive f (PrimLine a b) = PrimLine (f a) (f b)-mapPrimitive f (PrimTriangle a b c) = PrimTriangle (f a) (f b) (f c)--}--fetch_ :: forall a t . (AttributeTuple t) => String -> t -> PrimitiveStream a t-fetchArrays_ :: forall a t t' . (AttributeTuple t, t ~ FTRepr' t') => t' -> PrimitiveStream a t--mapPrimitives :: (a -> b) -> PrimitiveStream p a -> PrimitiveStream p b-mapPrimitives f = map (mapPrimitive f)--fetch s a t = fetch_ @a s t-fetchArrays a t = fetchArrays_ @a t--type family RemSemantics a where- RemSemantics () = ()- RemSemantics (Color a) = a- RemSemantics (Color a, Color b) = (a, b)- RemSemantics (Color a, Color b, Color c) = (a, b, c)- RemSemantics (Color a, Color b, Color c, Color d) = (a, b, c, d)- RemSemantics (Color a, Color b, Color c, Color d, Color e) = (a, b, c, d, e)- RemSemantics (Depth Float) = ()- RemSemantics (Depth Float, Color a) = a- RemSemantics (Depth Float, Color a, Color b) = (a, b)- RemSemantics (Depth Float, Color a, Color b, Color c) = (a, b, c)- RemSemantics (Depth Float, Color a, Color b, Color c, Color d) = (a, b, c, d)-----------------------data Maybe a- = Nothing- | Just a--- deriving (Eq, Ord, Show)--data Vector (n :: Nat) t--type Fragment n t = Vector n (Maybe (SimpleFragment t))--data SimpleFragment t = SimpleFragment- { sFragmentCoords :: Vec 3 Float- , sFragmentValue :: t- }--type FragmentStream n t = [Fragment n t]--customizeDepth :: (a -> Float) -> Fragment n a -> Fragment n a--customizeDepths :: (a -> Float) -> FragmentStream n a -> FragmentStream n a-customizeDepths f = map (customizeDepth f)--filterFragment :: (a -> Bool) -> Fragment n a -> Fragment n a--filterFragments :: (a -> Bool) -> FragmentStream n a -> FragmentStream n a-filterFragments p = map (filterFragment p)--mapFragment :: (a -> b) -> Fragment n a -> Fragment n b--mapFragments :: (a -> b) -> FragmentStream n a -> FragmentStream n b-mapFragments f = map (mapFragment f)-+data FragmentOperation :: ImageKind -> Type where+ ColorOp :: Num c => Blending c -> VecScalar d Bool -> FragmentOperation (Color (VecScalar d c))+ DepthOp :: ComparisonFunction -> Bool -> FragmentOperation Depth+ StencilOp :: StencilTests -> StencilOps -> StencilOps -> FragmentOperation Stencil data Interpolated t where Smooth, NoPerspective :: (Floating t) => Interpolated t Flat :: Interpolated t -type family InterpolatedType a where- InterpolatedType () = ()- InterpolatedType (Interpolated a) = a- InterpolatedType (Interpolated a, Interpolated b) = (a, b)- InterpolatedType (Interpolated a, Interpolated b, Interpolated c) = (a, b, c)- rasterizePrimitive- :: ( b ~ InterpolatedType interpolation- , a ~ JoinTupleType (Vec 4 Float) b )- => interpolation -- tuple of Smooth & Flat- -> RasterContext a x- -> Primitive a x- -> FragmentStream 1 b+ :: ( map Interpolated b ~ interpolation+ , a ~ 'Cons (Vec 4 Float) b )+ => HList interpolation -- tuple of Smooth & Flat+ -> RasterContext (HList a) x+ -> Primitive (HList a) x+ -> FragmentStream 1 (HList b) rasterizePrimitives ctx is s = concat (map (rasterizePrimitive is ctx) s) -data Image :: Nat -> Type -> Type+type family ImageLC a :: Nat where ImageLC (Image n t) = n -ColorImage :: forall a d t color . (Num t, color ~ VecScalar d t)- => color -> Image a (Color color)-DepthImage :: forall a . Float -> Image a (Depth Float)-StencilImage :: forall a . Int -> Image a (Stencil Int)+allSame :: [a] -> Type+allSame [] = 'Unit+allSame [x] = 'Unit+allSame (x: y: xs) = 'T2 (x ~ y) (allSame (y:xs)) -type family SameLayerCounts a where- SameLayerCounts (Image n1 t1) = Unit- SameLayerCounts (Image n1 t1, Image n2 t2) = EqCT Nat n1 n2- SameLayerCounts (Image n1 t1, Image n2 t2, Image n3 t3) = T2 (EqCT Nat n1 n2) (EqCT Nat n1 n3)+sameLayerCounts a = allSame (map 'ImageLC a) -class DefaultFragOp a where defaultFragOp :: FragmentOperation a-instance DefaultFragOp (Color (VecS Float 4)) where defaultFragOp = ColorOp NoBlending (V4 True True True True)-instance DefaultFragOp (Depth Float) where defaultFragOp = DepthOp Less True {-+defaultFragOp :: forall (a :: ImageKind) -> FragmentOperation a+defaultFragOp (Color '(VecS Float 4)) = ColorOp NoBlending (V4 True True True True)+defaultFragOp Depth = DepthOp Less True+ class DefaultFragOps a where defaultFragOps :: a instance (DefaultFragOp a, DefaultFragOp b) => DefaultFragOps (FragmentOperation a, FragmentOperation b) where defaultFragOps = -- (undefined @(), undefined) (defaultFragOp @a @_, defaultFragOp @b @_) -}-data FrameBuffer (n :: Nat) t-Accumulate :: FragOps b -> FragmentStream n (RemSemantics b) -> FrameBuffer n b -> FrameBuffer n b+data FrameBuffer (n :: Nat) (t :: [ImageKind]) -type family TFFrameBuffer a where- TFFrameBuffer (Image n1 t1) = FrameBuffer n1 t1- TFFrameBuffer (Image n1 t1, Image n2 t2) = FrameBuffer n1 (t1, t2)- TFFrameBuffer (Image n1 t1, Image n2 t2, Image n3 t3) = FrameBuffer n1 (t1, t2, t3)+imageType' :: [ImageKind] -> [Type]+imageType' (Depth: x) = map imageType x +imageType' x = map imageType x -FrameBuffer :: (ValidFrameBuffer b, SameLayerCounts a, FrameBuffer n b ~ TFFrameBuffer a) => a -> FrameBuffer n b+type family FragmentOperationKind a :: ImageKind where FragmentOperationKind (FragmentOperation x) = x -accumulate ctx fshader fstr fb = Accumulate ctx (mapFragments fshader fstr) fb+Accumulate :: forall (n :: Nat) (c :: [Type]) . (b ~ map FragmentOperationKind c) => HList c -> FragmentStream n (HList (imageType' b)) -> FrameBuffer n b -> FrameBuffer n b -accumulationContext x = x+accumulateWith ctx x = (ctx, x)+overlay cl (ctx, str) = Accumulate ctx str cl --- texture support-PrjImage :: FrameBuffer 1 a -> Image 1 a-PrjImageColor :: FrameBuffer 1 (Depth Float, Color (Vec 4 Float)) -> Image 1 (Color (Vec 4 Float))+infixl 0 `overlay` -data Output where- ScreenOut :: FrameBuffer a b -> Output+type family GetImageKind a :: ImageKind where GetImageKind (Image n t) = t ----------------------------------------------------------------------- * Builtin Primitive Functions *--- Arithmetic Functions (componentwise)+--class ValidFrameBuffer (a :: [ImageKind])+--instance ValidFrameBuffer a -- TODO -PrimAdd, PrimSub, PrimMul :: Num (MatVecScalarElem a) => a -> a -> a-PrimAddS, PrimSubS, PrimMulS :: (t ~ MatVecScalarElem a, Num t) => a -> t -> a-PrimDiv, PrimMod :: (Num t, a ~ VecScalar d t) => a -> a -> a-PrimDivS, PrimModS :: (Num t, a ~ VecScalar d t) => a -> t -> a-PrimNeg :: Signed (MatVecScalarElem a) => a -> a--- Bit-wise Functions-PrimBAnd, PrimBOr, PrimBXor :: (Integral t, a ~ VecScalar d t) => a -> a -> a-PrimBAndS, PrimBOrS, PrimBXorS:: (Integral t, a ~ VecScalar d t) => a -> t -> a-PrimBNot :: (Integral t, a ~ VecScalar d t) => a -> a-PrimBShiftL, PrimBShiftR :: (Integral t, a ~ VecScalar d t, b ~ VecScalar d Word) => a -> b -> a-PrimBShiftLS, PrimBShiftRS :: (Integral t, a ~ VecScalar d t) => a -> Word -> a--- Logic Functions-PrimAnd, PrimOr, PrimXor :: Bool -> Bool -> Bool-PrimNot :: (a ~ VecScalar d Bool) => a -> a-PrimAny, PrimAll :: VecScalar d Bool -> Bool+-- todo: rename to imageFrame+FrameBuffer :: forall (a :: [Type]) . (sameLayerCounts a) => HList a -> FrameBuffer (ImageLC (head a)) (map GetImageKind a) --- Angle, Trigonometry and Exponential Functions-PrimACos, PrimACosH, PrimASin, PrimASinH, PrimATan, PrimATanH, PrimCos, PrimCosH, PrimDegrees, PrimRadians, PrimSin, PrimSinH, PrimTan, PrimTanH, PrimExp, PrimLog, PrimExp2, PrimLog2, PrimSqrt, PrimInvSqrt- :: (a ~ VecScalar d Float) => a -> a-PrimPow, PrimATan2 :: (a ~ VecScalar d Float) => a -> a -> a--- Common Functions-PrimFloor, PrimTrunc, PrimRound, PrimRoundEven, PrimCeil, PrimFract- :: (a ~ VecScalar d Float) => a -> a-PrimMin, PrimMax :: (Num t, a ~ VecScalar d t) => a -> a -> a-PrimMinS, PrimMaxS :: (Num t, a ~ VecScalar d t) => a -> t -> a-PrimIsNan, PrimIsInf :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> b-PrimAbs, PrimSign :: (Signed t, a ~ VecScalar d t) => a -> a-PrimModF :: (a ~ VecScalar d Float) => a -> (a, a)-PrimClamp :: (Num t, a ~ VecScalar d t) => a -> a -> a -> a-PrimClampS :: (Num t, a ~ VecScalar d t) => a -> t -> t -> a-PrimMix :: (a ~ VecScalar d Float) => a -> a -> a -> a-PrimMixS :: (a ~ VecScalar d Float) => a -> a -> Float -> a-PrimMixB :: (a ~ VecScalar d Float, b ~ VecScalar d Bool) => a -> a -> b -> a-PrimStep :: (a ~ TFVec d Float) => a -> a -> a-PrimStepS :: (a ~ VecScalar d Float) => Float -> a -> a-PrimSmoothStep :: (a ~ TFVec d Float) => a -> a -> a -> a-PrimSmoothStepS :: (a ~ VecScalar d Float) => Float -> Float -> a -> a+imageFrame = FrameBuffer --- Integer/Floatonversion Functions-PrimFloatBitsToInt :: VecScalar d Float -> VecScalar d Int-PrimFloatBitsToUInt :: VecScalar d Float -> VecScalar d Word-PrimIntBitsToFloat :: VecScalar d Int -> VecScalar d Float-PrimUIntBitsToFloat :: VecScalar d Word -> VecScalar d Float--- Geometric Functions-PrimLength :: (a ~ VecScalar d Float) => a -> Float-PrimDistance, PrimDot :: (a ~ VecScalar d Float) => a -> a -> Float-PrimCross :: (a ~ VecScalar 3 Float) => a -> a -> a-PrimNormalize :: (a ~ VecScalar d Float) => a -> a-PrimFaceForward, PrimRefract :: (a ~ VecScalar d Float) => a -> a -> a -> a-PrimReflect :: (a ~ VecScalar d Float) => a -> a -> a--- Matrix Functions-PrimTranspose :: Mat h w a -> Mat w h a-PrimDeterminant :: Mat s s a -> Float-PrimInverse :: Mat s s a -> Mat s s a-PrimOuterProduct :: Vec w a -> Vec h a -> Mat h w a-PrimMulMatVec :: Mat h w a -> Vec w a -> Vec h a-PrimMulVecMat :: Vec h a -> Mat h w a -> Vec w a-PrimMulMatMat :: Mat i j a -> Mat j k a -> Mat i k a--- Vector and Scalar Relational Functions-PrimLessThan, PrimLessThanEqual, PrimGreaterThan, PrimGreaterThanEqual, PrimEqualV, PrimNotEqualV- :: (Num t, a ~ VecScalar d t, b ~ VecScalar d Bool) => a -> a -> b-PrimEqual, PrimNotEqual :: (t ~ MatVecScalarElem a) => a -> a -> Bool--- Fragment Processing Functions-PrimDFdx, PrimDFdy, PrimFWidth- :: (a ~ VecScalar d Float) => a -> a--- Noise Functions-PrimNoise1 :: VecScalar d Float -> Float-PrimNoise2 :: VecScalar d Float -> Vec 2 Float-PrimNoise3 :: VecScalar d Float -> Vec 3 Float-PrimNoise4 :: VecScalar d Float -> Vec 4 Float+accumulate ctx fshader fstr fb = Accumulate ctx (mapFragments fshader fstr) fb -{---- Vec/Mat (de)construction-PrimTupToV2 :: Component a => PrimFun stage ((a,a) -> V2 a)-PrimTupToV3 :: Component a => PrimFun stage ((a,a,a) -> V3 a)-PrimTupToV4 :: Component a => PrimFun stage ((a,a,a,a) -> V4 a)-PrimV2ToTup :: Component a => PrimFun stage (V2 a -> (a,a))-PrimV3ToTup :: Component a => PrimFun stage (V3 a -> (a,a,a))-PrimV4ToTup :: Component a => PrimFun stage (V4 a -> (a,a,a,a))--}+-- texture support+PrjImage :: FrameBuffer 1 '[a] -> Image 1 a+PrjImageColor :: FrameBuffer 1 '[ 'Depth, 'Color (Vec 4 Float)] -> Image 1 (Color (Vec 4 Float)) +data Output where+ ScreenOut :: FrameBuffer a b -> Output++renderFrame = ScreenOut+ -------------------- -- * Texture support -- FIXME: currently only Float RGBA 2D texture is supported@@ -561,12 +569,7 @@ texture2D :: Sampler -> Vec 2 Float -> Vec 4 Float -accumulateWith ctx x = (ctx, x)-overlay cl (ctx, str) = Accumulate ctx str cl-renderFrame = ScreenOut-imageFrame = FrameBuffer-emptyDepthImage = DepthImage @1-emptyColorImage = ColorImage @1+-- todo: remove+accumulationContext x = x -infixl 0 `overlay`
lc/Internals.lc view
@@ -5,6 +5,9 @@ -- used for type annotations typeAnn x = x +-- used for recognising double parenthesis+parens x = x+ undefined :: forall (a :: Type) . a primFix :: forall (a :: Type) . (a -> a) -> a@@ -13,36 +16,26 @@ data String data Empty (a :: String) --- TODO: generate?-data Tuple0 = Tuple0-data Tuple1 a = Tuple1 a-data Tuple2 a b = Tuple2 a b-data Tuple3 a b c = Tuple3 a b c-data Tuple4 a b c d = Tuple4 a b c d-data Tuple5 a b c d e = Tuple5 a b c d e+unsafeCoerce :: forall a b . a -> b +-- equality constraints+type family EqCT (t :: Type) (a :: t) (b :: t)+{-+coe :: forall (a :: Type) (b :: Type) -> EqCT Type a b -> a -> b+coe a b TT x = unsafeCoerce @a @b x+-}+ -- ... TODO -- builtin used for overlapping instances parEval :: forall a -> a -> a -> a -type family JoinTupleType t1 t2 where- -- TODO- JoinTupleType a () = a- JoinTupleType a (b, c) = (a, b, c)- JoinTupleType a (b, c, d) = (a, b, c, d)- JoinTupleType a (b, c, d, e) = (a, b, c, d, e)- JoinTupleType a b = (a, b)- -- conjuction of constraints type family T2 a b --- equality constraints-type family EqCT (t :: Type) (a :: t) (b :: t)--type EqCTt = EqCT Type+match'Type :: forall (m :: Type -> Type) -> m Type -> forall (t :: Type) -> m t -> m t ---type instance EqCT t (a, b) (JoinTupleType a' b') = T2 (EqCT Type a a') (EqCT Type b b')+type EqCTt = EqCT _ -- builtin conjuction of constraint witnesses t2C :: Unit -> Unit -> Unit@@ -129,5 +122,32 @@ data List a = Nil | Cons a (List a) infixr 5 :++data HList :: [Type] -> Type where+ HNil :: HList '[]+ HCons :: x -> HList xs -> HList '(x: xs)++hlistNilCase :: forall c -> c -> HList Nil -> c+hlistConsCase+ :: forall (e :: Type) (f :: List Type)+ . forall c+ -> (e -> HList f -> c)+ -> HList (Cons e f)+ -> c++{-+-- TODO: unsafeCoerce is not really needed here+hlistConsCase @e @f c fv x = 'HListCase + (\_ _ -> c)+ undefined+ (\ @t @lt y ys -> fv (unsafeCoerce @t @e y) (unsafeCoerce @(HList lt) @(HList f) ys))+ x++hlistNilCase c x v = 'HListCase+ (\_ _ -> c)+ x+ (\_ _ -> undefined :: c)+ v+-}
lc/Prelude.lc view
@@ -26,7 +26,7 @@ (***) f g (x, y) = (f x, g y) -pi = 3.14+pi = 3.141592653589793 zip :: [a] -> [b] -> [(a,b)] zip [] xs = []@@ -43,8 +43,8 @@ True -> (x : filter pred xs) False -> (filter pred xs) -head :: [a] -> a-head (a: _) = a+--head :: [a] -> a+--head (a: _) = a tail :: [a] -> [a] tail (_: xs) = xs@@ -76,13 +76,6 @@ fst (a, b) = a snd (a, b) = b -tuptype :: [Type] -> Type-tuptype [] = '()-tuptype (x:xs) = '(x, tuptype xs)--data RecordC (xs :: [(String, Type)])- = RecordCons (tuptype (map snd xs))- False ||| x = x True ||| x = True @@ -125,16 +118,24 @@ record :: [(String, Type)] -> Type --record xs = RecordCons ({- TODO: sortBy fst-} xs) -}--- builtin-unsafeCoerce :: forall a b . a -> b +data RecItem = RecItem String Type++recItemType (RecItem _ t) = t++data RecordC (xs :: [RecItem])+ = RecordCons (HList (map recItemType xs))+ isKeyC _ _ [] = 'Empty ""-isKeyC s t ((s', t'): ss) = if s == s' then t ~ t' else isKeyC s t ss+isKeyC s t (RecItem s' t': ss) = if s == s' then t ~ t' else isKeyC s t ss +fstTup (HCons a _) = a+sndTup (HCons _ a) = a+ -- todo: don't use unsafeCoerce-project :: forall a (xs :: [(String, Type)]) . forall (s :: String) -> 'isKeyC s a xs => RecordC xs -> a-project @a @((s', a'): xs) s @_ (RecordCons ts) | s == s' = fst (unsafeCoerce @_ @(a, tuptype (map snd xs)) ts)-project @a @((s', a'): xs) s @_ (RecordCons ts) = project @a @xs s @(undefined @(isKeyC s a xs)) (RecordCons (snd (unsafeCoerce @_ @(a, tuptype (map snd xs)) ts)))+project :: forall a (xs :: [RecItem]) . forall (s :: String) -> isKeyC s a xs => RecordC xs -> a+project @a @(RecItem s' a': xs) s @_ (RecordCons ts) | s == s' = fstTup (unsafeCoerce @_ @(HList '(a : map recItemType xs)) ts)+project @a @(RecItem s' a': xs) s @_ (RecordCons ts) = project @a @xs s @(undefined @(isKeyC s a xs)) (RecordCons (sndTup (unsafeCoerce @_ @(HList '(a : map recItemType xs)) ts))) --------------------------------------- HTML colors @@ -244,6 +245,23 @@ inv = PrimInverse outer = PrimOuterProduct +bAnd = PrimBAnd+bOr = PrimBOr+bXor = PrimBXor+bNot = PrimBNot+bAndS = PrimBAndS+bOrS = PrimBOrS+bXorS = PrimBXorS+shiftL = PrimBShiftL+shiftR = PrimBShiftR+shiftLS = PrimBShiftLS+shiftRS = PrimBShiftRS++floatBitsToInt = PrimFloatBitsToInt+floatBitsToWord = PrimFloatBitsToUInt+intBitsToFloat = PrimIntBitsToFloat+wordBitsToFloat = PrimUIntBitsToFloat+ -- operators infixl 7 *, /, % infixl 6 +, -@@ -303,24 +321,24 @@ ------------------ -- common matrices -------------------{-+ -- | Perspective transformation matrix in row major order. perspective :: Float -- ^ Near plane clipping distance (always positive). -> Float -- ^ Far plane clipping distance (always positive). -> Float -- ^ Field of view of the y axis, in radians. -> Float -- ^ Aspect ratio, i.e. screen's width\/height. -> Mat 4 4 Float-perspective n f fovy aspect = --transpose $- M44F (V4F (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)- (V4F 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)- (V4F 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))- (V4F 0 0 (-1) 0)+perspective n f fovy aspect =+ M44F (V4 (2*n/(r-l)) 0 0 0)+ (V4 0 (2*n/(t-b)) 0 0)+ (V4 ((r+l)/(r-l)) ((t+b)/(t-b)) (-(f+n)/(f-n)) (-1))+ (V4 0 0 (-2*f*n/(f-n)) 0) where t = n*tan(fovy/2) b = -t r = aspect*t l = -r--}+ rotMatrixZ a = M44F (V4 c s 0 0) (V4 (-s) c 0 0) (V4 0 0 1 0) (V4 0 0 0 1) where c = cos a@@ -338,24 +356,33 @@ rotationEuler a b c = rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c -{-+translateBefore4 :: Vec 3 Float -> Mat 4 4 Float+translateBefore4 v = M44F r1 r2 r3 r4+ where+ r1 = V4 1 0 0 0+ r2 = V4 0 1 0 0+ r3 = V4 0 0 1 0+ r4 = V4 v%x v%y v%z 1+ -- | Camera transformation matrix. lookat :: Vec 3 Float -- ^ Camera position. -> Vec 3 Float -- ^ Target position. -> Vec 3 Float -- ^ Upward direction.- -> M44F-lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)+ -> Mat 4 4 Float+lookat pos target up = r .*. translateBefore4 (neg pos) where+ ext0 a = V4 a%x a%y a%z 0 w = normalize $ pos - target u = normalize $ up `cross` w v = w `cross` u- r = transpose $ Mat3 u v w--}+ r = transpose $ M44F (ext0 u) (ext0 v) (ext0 w) (V4 0 0 0 1) scale t v = v * V4 t t t 1.0 fromTo :: Float -> Float -> [Float]-fromTo a b = if a > b then [] else a: fromTo (a +! 1.0) b+fromTo a b+ | a > b = []+ | otherwise = a: fromTo (a + 1) b (!!) :: [a] -> Int -> a (x : _) !! 0 = x
src/LambdaCube/Compiler.hs view
@@ -5,76 +5,143 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoMonomorphismRestriction #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadMask m => MonadMask (ExceptT e m) module LambdaCube.Compiler ( Backend(..) , Pipeline- , Infos, listInfos, Range(..)- , ErrorMsg(..)- , Exp, outputType, boolType, trueExp+ , module Exported , MMT, runMMT, mapMMT , MM, runMM- , Err- , catchMM, catchErr- , ioFetch+ , catchErr+ , ioFetch, decideFilePath , getDef, compileMain, preCompile , removeFromCache , compilePipeline , ppShow+ , prettyShowUnlines ) where -import Data.Char import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Control.Monad.State+import Data.Maybe+import Data.Function+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Except-import Control.Monad.Identity import Control.DeepSeq import Control.Monad.Catch import Control.Exception hiding (catch, bracket, finally, mask) import Control.Arrow hiding ((<+>)) import System.Directory import System.FilePath---import Debug.Trace import qualified Data.Text as T import qualified Data.Text.IO as TIO+import qualified Text.Show.Pretty as PP import LambdaCube.IR as IR import LambdaCube.Compiler.Pretty hiding ((</>))-import LambdaCube.Compiler.Infer (Infos, listInfos, ErrorMsg(..), PolyEnv(..), Export(..), Module(..), ErrorT, throwErrorTCM, parseLC, joinPolyEnvs, filterPolyEnv, inference_, ImportItems (..), Range(..), Exp, outputType, boolType, trueExp)+import LambdaCube.Compiler.Parser (Module(..), Export(..), ImportItems (..), runDefParser, parseLC)+import LambdaCube.Compiler.Lexer (DesugarInfo)+import LambdaCube.Compiler.Lexer as Exported (Range(..))+import LambdaCube.Compiler.Infer (showError, inference, GlobalEnv, initEnv)+import LambdaCube.Compiler.Infer as Exported (Infos, listAllInfos, listTypeInfos, listTraceInfos, errorRange, Exp, outputType, boolType, trueExp, unfixlabel) import LambdaCube.Compiler.CoreToIR -- inlcude path for: Builtins, Internals and Prelude import Paths_lambdacube_compiler (getDataDir) -type EName = String-type MName = String+-------------------------------------------------------------------------------- -type Modules = Map FilePath (Either Doc PolyEnv)-type ModuleFetcher m = Maybe FilePath -> MName -> m (FilePath, String)+readFileStrict :: FilePath -> IO String+readFileStrict = fmap T.unpack . TIO.readFile -newtype MMT m a = MMT { runMMT :: ReaderT (ModuleFetcher (MMT m)) (ErrorT (StateT Modules (WriterT Infos m))) a }- deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m)), MonadState Modules, MonadError ErrorMsg, MonadIO, MonadThrow, MonadCatch, MonadMask)-type MM = MMT IO+readFile' :: FilePath -> IO (Maybe (IO String))+readFile' fname = do+ b <- doesFileExist fname+ return $ if b then Just $ readFileStrict fname else Nothing instance MonadMask m => MonadMask (ExceptT e m) where mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u) uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT" -mapMMT f (MMT m) = MMT $ f m+prettyShowUnlines :: Show a => a -> String+prettyShowUnlines = goPP 0 . PP.ppShow+ where+ goPP _ [] = []+ goPP n ('"':xs) | isMultilineString xs = "\"\"\"\n" ++ indent ++ go xs where+ indent = replicate n ' '+ go ('\\':'n':xs) = "\n" ++ indent ++ go xs+ go ('\\':c:xs) = '\\':c:go xs+ go ('"':xs) = "\n" ++ indent ++ "\"\"\"" ++ goPP n xs+ go (x:xs) = x : go xs+ goPP n (x:xs) = x : goPP (if x == '\n' then 0 else n+1) xs -type Err a = (Either ErrorMsg a, Infos)+ isMultilineString ('\\':'n':xs) = True+ isMultilineString ('\\':c:xs) = isMultilineString xs+ isMultilineString ('"':xs) = False+ isMultilineString (x:xs) = isMultilineString xs+ isMultilineString [] = False -runMM :: Monad m => ModuleFetcher (MMT m) -> MMT m a -> m (Err a) +--------------------------------------------------------------------------------++type MName = String+type SName = String+type SourceCode = String++-- file name or module name?+decideFilePath n+ | takeExtension n == ".lc" = Left n+ | otherwise = Right n++dropExtension' e f+ | takeExtension f == e = dropExtension f+ | otherwise = error $ "dropExtension: expcted extension: " ++ e ++ " ; filename: " ++ f++fileNameToModuleName n+ = intercalate "." $ remDot $ (\(a, b) -> map takeDirectory (splitPath a) ++ [b]) $ splitFileName $ dropExtension' ".lc" $ normalise n+ where+ remDot (".": xs) = xs+ remDot xs = xs++moduleNameToFileName n = hn n ++ ".lc"+ where+ hn = h []+ h acc [] = reverse acc+ h acc ('.':cs) = reverse acc </> hn cs+ h acc (c: cs) = h (c: acc) cs++type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either String (FilePath, MName, m SourceCode))++ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m x)+ioFetch paths' imp n = do+ preludePath <- (</> "lc") <$> liftIO getDataDir+ let paths = paths' ++ [preludePath]+ find ((x, mn): xs) = liftIO (readFile' x) >>= maybe (find xs) (\src -> return $ Right (x, mn, liftIO src))+ find [] = return $ Left $ show $ "can't find " <+> either (("lc file" <+>) . text) (("module" <+>) . text) n+ <+> "in path" <+> hsep (map text (paths' ++ ["<<installed-prelude-path>>"]{-todo-}))+ find $ nubBy ((==) `on` fst) $ map (first normalise . lcModuleFile) paths+ where+ lcModuleFile path = case n of+ Left n -> (path </> n, fileNameToModuleName n)+ Right n -> (path </> moduleNameToFileName n, n)++--------------------------------------------------------------------------------++newtype MMT m x a = MMT { runMMT :: ReaderT (ModuleFetcher (MMT m x)) (StateT (Modules x) m) a }+ deriving (Functor, Applicative, Monad, MonadReader (ModuleFetcher (MMT m x)), MonadState (Modules x), MonadIO, MonadThrow, MonadCatch, MonadMask)++type MM = MMT IO Infos++mapMMT f (MMT m) = MMT $ f m++runMM :: Monad m => ModuleFetcher (MMT m x) -> MMT m x a -> m a runMM fetcher- = runWriterT- . flip evalStateT mempty- . runExceptT+ = flip evalStateT mempty . flip runReaderT fetcher . runMMT @@ -84,126 +151,106 @@ getErr (e :: ErrorCall) = catchErr er $ er $ show e getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e -catchMM :: Monad m => MMT m a -> (ErrorMsg -> MMT m a) -> MMT m a-catchMM m e = mapMMT (mapReaderT $ lift . runExceptT) m >>= either e return---- TODO: remove dependent modules from cache too-removeFromCache :: Monad m => FilePath -> MMT m ()+-- TODO: remove dependent modules from cache too?+removeFromCache :: Monad m => FilePath -> MMT m x () removeFromCache f = modify $ Map.delete f -readFileStrict :: FilePath -> IO String-readFileStrict = fmap T.unpack . TIO.readFile--readFile' :: FilePath -> IO (Maybe String)-readFile' fname = do- b <- doesFileExist fname- if b then Just <$> readFileStrict fname else return Nothing--ioFetch :: MonadIO m => [FilePath] -> ModuleFetcher (MMT m)-ioFetch paths imp n = do- preludePath <- (</> "lc") <$> liftIO getDataDir- let- f [] = throwErrorTCM $ "can't find module" <+> hsep (map text fnames)- f (x:xs) = liftIO (readFile' x) >>= \case- Nothing -> f xs- Just src -> do- --liftIO $ putStrLn $ "loading " ++ x- return (x, src)- fnames = map normalise . concatMap lcModuleFile $ nub $ preludePath : paths- lcModuleFile path = (++ ".lc") <$> g imp- where- g Nothing = [path </> n]- g (Just fn) = [path </> hn, fst (splitMPath fn) </> hn]-- hn = h [] n- h acc [] = reverse acc- h acc ('.':cs) = reverse acc </> h [] cs- h acc (c: cs) = h (c: acc) cs- f fnames+type Module' x = (SourceCode, Either String{-error msg-} (Module, x, Either String{-error msg-} (DesugarInfo, GlobalEnv))) -splitMPath fn = (joinPath as, intercalate "." $ bs ++ [y])- where- (as, bs) = span (\x -> null x || x == "." || x == "/" || isLower (head x)) xs- (xs, y) = map takeDirectory . splitPath *** id $ splitFileName $ dropExtension fn+type Modules x = Map FilePath (Module' x) +(<&>) = flip (<$>) -loadModule :: MonadMask m => Maybe FilePath -> MName -> MMT m (FilePath, PolyEnv)-loadModule imp mname = do- fetch <- ask- (fname, src) <- fetch imp mname+loadModule :: MonadMask m => (Infos -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either String (FilePath, Module' x))+loadModule ex imp mname_ = do+ r <- ask >>= \fetch -> fetch imp mname_+ case r of+ Left err -> return $ Left err+ Right (fname, mname, srcm) -> do c <- gets $ Map.lookup fname case c of- Just (Right m) -> return (fname, m)- Just (Left e) -> throwErrorTCM $ "cycles in module imports:" <+> pShow mname <+> e- _ -> do- e <- MMT $ lift $ mapExceptT (lift . lift) $ parseLC fname src- modify $ Map.insert fname $ Left $ pShow $ map fst $ moduleImports e- let- loadModuleImports (m, is) = do- filterPolyEnv (filterImports is) . snd <$> loadModule (Just fname) m- do- ms <- mapM loadModuleImports $ moduleImports e- x' <- {-trace ("loading " ++ fname) $-} do- env <- joinPolyEnvs False ms- x <- MMT $ lift $ mapExceptT (lift . mapWriterT (return . runIdentity)) $ inference_ env e- case moduleExports e of- Nothing -> return x- Just es -> joinPolyEnvs False $ flip map es $ \exp -> case exp of- ExportId d -> case Map.lookup d $ getPolyEnv x of- Just def -> PolyEnv (Map.singleton d def) mempty- Nothing -> error $ d ++ " is not defined"- ExportModule m | m == snd (splitMPath mname) -> x- ExportModule m -> case [ ms- | ((m', is), ms) <- zip (moduleImports e) ms, m' == m] of- [PolyEnv x infos] -> PolyEnv x mempty -- TODO- [] -> error "empty export list"- _ -> error "export list: internal error"- modify $ Map.insert fname $ Right x'- return (fname, x')--- `finally` modify (Map.delete fname)- `catchMM` (\e -> modify (Map.delete fname) >> throwError e)+ Just x -> return $ Right (fname, x)+ Nothing -> do+ src <- srcm+ res <- case parseLC fname src of+ Left e -> return $ Left $ show e+ Right e -> do+ modify $ Map.insert fname (src, Right (e, ex mempty, Left $ show $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e)))+ srcs <- gets $ fmap fst+ ms <- forM (moduleImports e) $ \(m, is) -> loadModule ex (Just fname) (Right $ snd m) <&> \r -> case r of+ Left err -> Left $ snd m ++ " couldn't be found"+ Right (fb, (src, dsge)) ->+ either (Left . const (snd m ++ " couldn't be parsed"))+ (\(pm, x, e) -> either+ (Left . const (snd m ++ " couldn't be typechecked"))+ (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge))+ e)+ dsge -filterImports (ImportAllBut ns) = not . (`elem` ns)-filterImports (ImportJust ns) = (`elem` ns)+ let (res, err) = case sequence ms of+ Left err -> (ex mempty, Left err)+ Right ms@(mconcat -> (ds, ge)) -> case runExcept $ runDefParser ds $ definitions e of+ Left err -> (ex mempty, Left err)+ Right (defs, dsinfo) -> (,) (ex is) $ case res of+ Left err -> Left (showError srcs err)+ Right (mconcat -> newge) ->+ right mconcat $ forM (fromMaybe [ExportModule (mempty, mname)] $ moduleExports e) $ \case+ ExportId (snd -> d) -> case Map.lookup d newge of+ Just def -> Right (mempty{-TODO-}, Map.singleton d def)+ Nothing -> Left $ d ++ " is not defined"+ ExportModule (snd -> m) | m == mname -> Right (dsinfo, newge)+ ExportModule m -> case [ x | ((m', _), x) <- zip (moduleImports e) ms, m' == m] of+ [x] -> Right x+ [] -> Left $ "empty export list: " ++ show (fname, m, map fst $ moduleImports e, mname)+ _ -> error "export list: internal error"+ where+ (res, is) = runWriter . flip runReaderT (extensions e, initEnv <> ge) . runExceptT $ inference defs + return $ Right (e, res, err)+ modify $ Map.insert fname (src, res)+ return $ Right (fname, (src, res))+ where+ filterImports (ImportAllBut ns) = not . (`elem` map snd ns)+ filterImports (ImportJust ns) = (`elem` map snd ns)+ -- used in runTests-getDef :: MonadMask m => MName -> EName -> Maybe Exp -> MMT m (FilePath, Either String (Exp, Exp), Infos)-getDef m d ty = do- (fname, pe) <- loadModule Nothing m- return- ( fname- , case Map.lookup d $ getPolyEnv pe of- Just (e, thy, si)- | Just False <- (== thy) <$> ty -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy -- TODO: better type comparison+getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m Infos (Infos, Either String (FilePath, Either String (Exp, Exp)))+getDef m d ty = loadModule id Nothing (Left m) <&> \case+ Left err -> (mempty, Left err)+ Right (fname, (src, Left err)) -> (mempty, Left err)+ Right (fname, (src, Right (pm, infos, Left err))) -> (,) infos $ Left err+ Right (fname, (src, Right (pm, infos, Right (_, ge)))) -> (,) infos $ Right+ ( fname+ , case Map.lookup d ge of+ Just (e, thy, si)+ | Just False <- (== thy) <$> ty -- TODO: better type comparison+ -> Left $ "type of " ++ d ++ " should be " ++ show ty ++ " instead of " ++ ppShow thy | otherwise -> Right (e, thy)- Nothing -> Left $ d ++ " is not found"- , infos pe- )+ Nothing -> Left $ d ++ " is not found"+ ) -parseAndToCoreMain m = either (throwErrorTCM . text) return . (\(_, e, i) -> flip (,) i <$> e) =<< getDef m "main" (Just outputType)+compilePipeline' backend m+ = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef m "main" (Just outputType) -- | most commonly used interface for end users compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline) compileMain path backend fname- = fmap ((show +++ fst) . fst) $ runMM (ioFetch path) $ first (compilePipeline backend) <$> parseAndToCoreMain fname---- | Removes the escaping characters from the error message-removeEscapes = first ((\(ErrorMsg e) -> ErrorMsg (removeEscs e)) +++ id)+ = fmap snd $ runMM (ioFetch path) $ compilePipeline' backend fname -- used by the compiler-service of the online editor-preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> String -> IO (String -> m (Err (IR.Pipeline, Infos)))+preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either String IR.Pipeline, Infos)) preCompile paths paths' backend mod = do- res <- runMM (ioFetch paths) $ loadModule Nothing mod+ res <- runMM (ioFetch paths) $ loadModule id Nothing $ Left mod case res of- (Left err, i) -> error $ "Prelude could not compiled: " ++ show err - (Right (_, prelude), _) -> return compile+ Left err -> error $ "Prelude could not compiled: " ++ err+ Right (src, prelude) -> return compile where- compile src = fmap removeEscapes . runMM fetch $ do- modify $ Map.insert ("." </> "Prelude.lc") $ Right prelude- first (compilePipeline backend) <$> parseAndToCoreMain "Main"+ compile src = fmap (first (left removeEscs)) . runMM fetch $ do+ modify $ Map.insert ("." </> "Prelude.lc") prelude+ (snd &&& fst) <$> compilePipeline' backend "Main" where fetch imp = \case- "Prelude" -> return ("./Prelude.lc", undefined)- "Main" -> return ("./Main.lc", src)+ Left "Prelude" -> return $ Right ("./Prelude.lc", "Prelude", undefined)+ Left "Main" -> return $ Right ("./Main.lc", "Main", return src) n -> ioFetch paths' imp n
src/LambdaCube/Compiler/CoreToIR.hs view
@@ -3,1114 +3,996 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove-module LambdaCube.Compiler.CoreToIR- ( compilePipeline- ) where--import Data.Char-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Vector ((!))-import qualified Data.Vector as Vector---import Control.Applicative-import Control.Arrow hiding ((<+>))-import Control.Monad.Writer-import Control.Monad.State-import Control.Monad.Reader---import Control.Monad.Except---import Control.Monad.Identity---import Text.Parsec.Pos---import Debug.Trace--import LambdaCube.IR(Backend(..))-import qualified LambdaCube.IR as IR-import qualified LambdaCube.Linear as IR--import LambdaCube.Compiler.Pretty hiding (parens)-import qualified LambdaCube.Compiler.Infer as I-import LambdaCube.Compiler.Infer (SName, Lit(..), Visibility(..))------------------------------------------------------------------------------type CG = State IR.Pipeline--pattern TFrameBuffer a b <- A2 "FrameBuffer" a b--emptyPipeline b = IR.Pipeline b mempty mempty mempty mempty mempty mempty mempty-update i x xs = xs Vector.// [(i,x)]--newTexture :: Int -> Int -> IR.ImageSemantic -> CG IR.TextureName-newTexture width height semantic = do- let sampleDescriptor = IR.SamplerDescriptor- { IR.samplerWrapS = IR.Repeat- , IR.samplerWrapT = Nothing- , IR.samplerWrapR = Nothing- , IR.samplerMinFilter = IR.Linear - , IR.samplerMagFilter = IR.Linear- , IR.samplerBorderColor = IR.VV4F (IR.V4 0 0 0 1)- , IR.samplerMinLod = Nothing- , IR.samplerMaxLod = Nothing- , IR.samplerLodBias = 0- , IR.samplerCompareFunc = Nothing- }-- textureDescriptor = IR.TextureDescriptor- { IR.textureType = IR.Texture2D (if semantic == IR.Color then IR.FloatT IR.RGBA else IR.FloatT IR.Red) 1- , IR.textureSize = IR.VV2U $ IR.V2 (fromIntegral width) (fromIntegral height)- , IR.textureSemantic = semantic- , IR.textureSampler = sampleDescriptor- , IR.textureBaseLevel = 0- , IR.textureMaxLevel = 0- }- tv <- gets IR.textures- modify (\s -> s {IR.textures = tv <> pure textureDescriptor})- return $ length tv--newFrameBufferTarget :: Ty -> CG IR.RenderTargetName-newFrameBufferTarget (TFrameBuffer _ a) = do- let t = IR.RenderTarget $ Vector.fromList [IR.TargetItem s (Just (IR.Framebuffer s)) | s <- compSemantic a]- tv <- gets IR.targets- modify (\s -> s {IR.targets = tv <> pure t})- return $ length tv-newFrameBufferTarget x = error $ "newFrameBufferTarget illegal target type: " ++ ppShow x--newTextureTarget :: Int -> Int -> Ty -> CG IR.RenderTargetName-newTextureTarget w h (TFrameBuffer _ a) = do- tl <- forM (compSemantic a) $ \s -> do- texture <- newTexture w h s- return $ IR.TargetItem s (Just (IR.TextureImage texture 0 Nothing))- tv <- gets IR.targets- modify (\s -> s {IR.targets = tv <> pure (IR.RenderTarget $ Vector.fromList tl)})- return $ Vector.length tv-newTextureTarget _ _ x = error $ "newTextureTarget illegal target type: " ++ ppShow x--compilePipeline :: IR.Backend -> I.ExpType -> IR.Pipeline-compilePipeline b e = flip execState (emptyPipeline b) $ do- (subCmds,cmds) <- getCommands $ toExp e- modify (\s -> s {IR.commands = Vector.fromList subCmds <> Vector.fromList cmds})--mergeSlot a b = a- { IR.slotUniforms = IR.slotUniforms a <> IR.slotUniforms b- , IR.slotStreams = IR.slotStreams a <> IR.slotStreams b- , IR.slotPrograms = IR.slotPrograms a <> IR.slotPrograms b- }--getSlot :: Exp -> CG (IR.Command,[(String,IR.InputType)])-getSlot e@(Prim2 "fetch_" (EString slotName) attrs) = do- let input = compAttribute attrs- slot = IR.Slot- { IR.slotName = slotName- , IR.slotUniforms = mempty- , IR.slotStreams = Map.fromList input- , IR.slotPrimitive = compFetchPrimitive $ getPrim $ tyOf e- , IR.slotPrograms = mempty- }- sv <- gets IR.slots- case Vector.findIndex ((slotName ==) . IR.slotName) sv of- Nothing -> do- modify (\s -> s {IR.slots = sv <> pure slot})- return (IR.RenderSlot $ length sv,input)- Just i -> do- modify (\s -> s {IR.slots = update i (mergeSlot (sv ! i) slot) sv})- return (IR.RenderSlot i,input)-getSlot e@(Prim1 "fetchArrays_" attrs) = do- let (input,values) = unzip [((name,ty),(name,value)) | (i,(ty,value)) <- zip [0..] (compAttributeValue attrs), let name = "attribute_" ++ show i]- stream = IR.StreamData- { IR.streamData = Map.fromList values- , IR.streamType = Map.fromList input- , IR.streamPrimitive = compFetchPrimitive $ getPrim $ tyOf e- , IR.streamPrograms = mempty- }- sv <- gets IR.streams- modify (\s -> s {IR.streams = sv <> pure stream})- return (IR.RenderStream $ length sv,input)-getSlot x = error $ "getSlot: " ++ ppShow x--getPrim (A1 "List" (A2 "Primitive" _ p)) = p-getPrim' (A1 "List" (A2 "Primitive" a _)) = a-getPrim'' (A1 "List" (A2 "Vector" _ (A1 "Maybe" (A1 "SimpleFragment" a)))) = a-getPrim'' x = error $ "getPrim'':" ++ ppShow x--addProgramToSlot :: IR.ProgramName -> IR.Command -> CG ()-addProgramToSlot prgName (IR.RenderSlot slotName) = do- sv <- gets IR.slots- pv <- gets IR.programs- let slot = sv ! slotName- prg = pv ! prgName- slot' = slot- { IR.slotUniforms = IR.slotUniforms slot <> IR.programUniforms prg- , IR.slotPrograms = IR.slotPrograms slot <> pure prgName- }- modify (\s -> s {IR.slots = update slotName slot' sv})-addProgramToSlot prgName (IR.RenderStream streamName) = do- sv <- gets IR.streams- pv <- gets IR.programs- let stream = sv ! streamName- prg = pv ! prgName- stream' = stream- { IR.streamPrograms = IR.streamPrograms stream <> pure prgName- }- modify (\s -> s {IR.streams = update streamName stream' sv})--getProgram :: [(String,IR.InputType)] -> IR.Command -> Exp -> Exp -> Exp -> Exp -> Maybe Exp -> CG IR.ProgramName-getProgram input slot rp is vert frag ffilter = do- backend <- gets IR.backend- let ((vertexInput,vertOut),vertSrc) = genVertexGLSL backend rp is vert- fragSrc = genFragmentGLSL backend pUniforms vertOut frag ffilter- pUniforms = Map.fromList $ Set.toList $ getUniforms vert <> getUniforms rp <> getUniforms frag <> maybe mempty getUniforms ffilter- prg = IR.Program- { IR.programUniforms = pUniforms- , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input- , IR.programInTextures = Map.fromList $ Set.toList $ getSamplerUniforms vert <> getSamplerUniforms rp <> getSamplerUniforms frag <> maybe mempty getSamplerUniforms ffilter- , IR.programOutput = pure $ IR.Parameter "f0" IR.V4F -- TODO- , IR.vertexShader = vertSrc- , IR.geometryShader = mempty -- TODO- , IR.fragmentShader = fragSrc- }- pv <- gets IR.programs- modify (\s -> s {IR.programs = pv <> pure prg})- let prgName = length pv- addProgramToSlot prgName slot- return prgName--getRenderTextures :: Exp -> [Exp]-getRenderTextures e = case e of- ELet (PVar (A0 "Sampler") _) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> [e]- Exp e -> foldMap getRenderTextures e--type SamplerBinding = (IR.UniformName,IR.ImageRef)--getRenderTextureCommands :: Exp -> CG ([SamplerBinding],[IR.Command])-getRenderTextureCommands e = foldM (\(a,b) x -> f x >>= (\(c,d) -> return (c:a,d ++ b))) mempty (getRenderTextures e)- where- f = \case- ELet (PVar t n) (A3 "Sampler" _ _ (A2 "Texture2D" (A2 "V2" (EInt w) (EInt h)) (Prim1 "PrjImageColor" a))) _ -> do- rt <- newTextureTarget (fromIntegral w) (fromIntegral h) (tyOf a)- tv <- gets IR.targets- let IR.RenderTarget (Vector.toList -> [_,IR.TargetItem IR.Color (Just (IR.TextureImage texture _ _))]) = tv ! rt- (subCmds,cmds) <- getCommands a- return ((n,IR.TextureImage texture 0 Nothing), subCmds <> (IR.SetRenderTarget rt:cmds))- ELet (PVar t n) (A3 "Sampler" _ _ (A2 "Texture2D" (A2 "V2" (EInt w) (EInt h)) (Prim1 "PrjImage" a))) _ -> do- rt <- newTextureTarget (fromIntegral w) (fromIntegral h) (tyOf a)- tv <- gets IR.targets- let IR.RenderTarget (Vector.toList -> [IR.TargetItem IR.Color (Just (IR.TextureImage texture _ _))]) = tv ! rt- (subCmds,cmds) <- getCommands a- return ((n,IR.TextureImage texture 0 Nothing), subCmds <> (IR.SetRenderTarget rt:cmds))- x -> error $ "getRenderTextureCommands: not supported render texture exp: " ++ ppShow x--getFragFilter (Prim2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x)-getFragFilter x = (Nothing, x)--getVertexShader (Prim2 "map" (EtaPrim2 "mapPrimitive" f) x) = (f, x)-getVertexShader x = (idFun $ getPrim' $ tyOf x, x)--getFragmentShader (Prim2 "map" (EtaPrim2 "mapFragment" f) x) = (f, x)-getFragmentShader x = (idFun $ getPrim'' $ tyOf x, x)--removeDepthHandler (Prim2 "map" (EtaPrim1 "noDepth") x) = x-removeDepthHandler x = x--getCommands :: Exp -> CG ([IR.Command],[IR.Command])-getCommands e = case e of- A1 "ScreenOut" a -> do- rt <- newFrameBufferTarget (tyOf a)- (subCmds,cmds) <- getCommands a- return (subCmds,IR.SetRenderTarget rt : cmds)- Prim3 "Accumulate" actx (getFragmentShader . removeDepthHandler -> (frag, getFragFilter -> (ffilter, Prim3 "foldr" (EtaPrim2_2 "++") (A0 "Nil") (Prim2 "map" (EtaPrim3 "rasterizePrimitive" is rctx) (getVertexShader -> (vert, input)))))) fbuf -> do- let rp = compRC' rctx- (smpBindingsV,vertCmds) <- getRenderTextureCommands vert- (smpBindingsR,rastCmds) <- maybe (return mempty) getRenderTextureCommands ffilter- (smpBindingsP,raspCmds) <- getRenderTextureCommands rp- (smpBindingsF,fragCmds) <- getRenderTextureCommands frag- (renderCommand,input) <- getSlot input- prog <- getProgram input renderCommand rp is vert frag ffilter- (subFbufCmds, fbufCommands) <- getCommands fbuf- programs <- gets IR.programs- let textureUniforms = [IR.SetSamplerUniform n textureUnit | ((n,IR.FTexture2D),textureUnit) <- zip (Map.toList $ IR.programUniforms $ programs ! prog) [0..]]- cmds =- [ IR.SetProgram prog ] <>- textureUniforms <>- concat -- TODO: generate IR.SetSamplerUniform commands for texture slots- [ [ IR.SetTexture textureUnit texture- , IR.SetSamplerUniform name textureUnit- ] | (textureUnit,(name,IR.TextureImage texture _ _)) <- zip [length textureUniforms..] (smpBindingsV <> smpBindingsP <> smpBindingsR <> smpBindingsF)- ] <>- [ IR.SetRasterContext (compRC rctx)- , IR.SetAccumulationContext (compAC actx)- , renderCommand- ]- return (subFbufCmds <> vertCmds <> raspCmds <> rastCmds <> fragCmds, fbufCommands <> cmds)- Prim1 "FrameBuffer" a -> return ([],[IR.ClearRenderTarget (Vector.fromList $ map (uncurry IR.ClearImage) $ compFrameBuffer a)])- x -> error $ "getCommands " ++ ppShow x--getSamplerUniforms :: Exp -> Set (String,IR.InputType)-getSamplerUniforms e = case e of- ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString s))) _ -> Set.singleton (s, IR.FTexture2D{-compInputType $ tyOf e-}) -- TODO- ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> Set.singleton (n, IR.FTexture2D)- Exp e -> foldMap getSamplerUniforms e--getUniforms :: Exp -> Set (String,IR.InputType)-getUniforms e = case e of- Uniform s -> Set.singleton (s, compInputType $ tyOf e)- ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString s))) _ -> Set.singleton (s, IR.FTexture2D{-compInputType $ tyOf e-}) -- TODO- ELet (PVar _ _) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> mempty- Exp e -> foldMap getUniforms e--compFrameBuffer x = case x of- ETuple a -> concatMap compFrameBuffer a- Prim1 "DepthImage" a -> [(IR.Depth, compValue a)]- Prim1 "ColorImage" a -> [(IR.Color, compValue a)]- x -> error $ "compFrameBuffer " ++ ppShow x--compSemantic x = case x of- TTuple t -> concatMap compSemantic t- A1 "Depth" _ -> return IR.Depth- A1 "Stencil" _ -> return IR.Stencil- A1 "Color" _ -> return IR.Color- x -> error $ "compSemantic " ++ ppShow x--compAC x = IR.AccumulationContext Nothing $ map compFrag $ case x of- ETuple a -> a- a -> [a]--compBlending x = case x of- A0 "NoBlending" -> IR.NoBlending- A1 "BlendLogicOp" a -> IR.BlendLogicOp (compLO a)- A3 "Blend" (ETuple [a,b]) (ETuple [ETuple [c,d],ETuple [e,f]]) (compValue -> IR.VV4F g) -> IR.Blend (compBE a) (compBE b) (compBF c) (compBF d) (compBF e) (compBF f) g- x -> error $ "compBlending " ++ ppShow x--compBF x = case x of- A0 "Zero'" -> IR.Zero- A0 "One" -> IR.One- A0 "SrcColor" -> IR.SrcColor- A0 "OneMinusSrcColor" -> IR.OneMinusSrcColor- A0 "DstColor" -> IR.DstColor- A0 "OneMinusDstColor" -> IR.OneMinusDstColor- A0 "SrcAlpha" -> IR.SrcAlpha- A0 "OneMinusSrcAlpha" -> IR.OneMinusSrcAlpha- A0 "DstAlpha" -> IR.DstAlpha- A0 "OneMinusDstAlpha" -> IR.OneMinusDstAlpha- A0 "ConstantColor" -> IR.ConstantColor- A0 "OneMinusConstantColor" -> IR.OneMinusConstantColor- A0 "ConstantAlpha" -> IR.ConstantAlpha- A0 "OneMinusConstantAlpha" -> IR.OneMinusConstantAlpha- A0 "SrcAlphaSaturate" -> IR.SrcAlphaSaturate- x -> error $ "compBF " ++ ppShow x--compBE x = case x of- A0 "FuncAdd" -> IR.FuncAdd- A0 "FuncSubtract" -> IR.FuncSubtract- A0 "FuncReverseSubtract" -> IR.FuncReverseSubtract- A0 "Min" -> IR.Min- A0 "Max" -> IR.Max- x -> error $ "compBE " ++ ppShow x--compLO x = case x of- A0 "Clear" -> IR.Clear- A0 "And" -> IR.And- A0 "AndReverse" -> IR.AndReverse- A0 "Copy" -> IR.Copy- A0 "AndInverted" -> IR.AndInverted- A0 "Noop" -> IR.Noop- A0 "Xor" -> IR.Xor- A0 "Or" -> IR.Or- A0 "Nor" -> IR.Nor- A0 "Equiv" -> IR.Equiv- A0 "Invert" -> IR.Invert- A0 "OrReverse" -> IR.OrReverse- A0 "CopyInverted" -> IR.CopyInverted- A0 "OrInverted" -> IR.OrInverted- A0 "Nand" -> IR.Nand- A0 "Set" -> IR.Set- x -> error $ "compLO " ++ ppShow x--compComparisonFunction x = case x of- A0 "Never" -> IR.Never- A0 "Less" -> IR.Less- A0 "Equal" -> IR.Equal- A0 "Lequal" -> IR.Lequal- A0 "Greater" -> IR.Greater- A0 "Notequal" -> IR.Notequal- A0 "Gequal" -> IR.Gequal- A0 "Always" -> IR.Always- x -> error $ "compComparisonFunction " ++ ppShow x--pattern EBool a <- (compBool -> Just a)--compBool x = case x of- A0 "True" -> Just True- A0 "False" -> Just False- x -> Nothing--compFrag x = case x of- A2 "DepthOp" (compComparisonFunction -> a) (EBool b) -> IR.DepthOp a b- A2 "ColorOp" (compBlending -> b) (compValue -> v) -> IR.ColorOp b v- x -> error $ "compFrag " ++ ppShow x--compInputType x = case x of- TFloat -> IR.Float- TVec 2 TFloat -> IR.V2F- TVec 3 TFloat -> IR.V3F- TVec 4 TFloat -> IR.V4F- TBool -> IR.Bool- TVec 2 TBool -> IR.V2B- TVec 3 TBool -> IR.V3B- TVec 4 TBool -> IR.V4B- TInt -> IR.Int- TVec 2 TInt -> IR.V2I- TVec 3 TInt -> IR.V3I- TVec 4 TInt -> IR.V4I- TWord -> IR.Word- TVec 2 TWord -> IR.V2U- TVec 3 TWord -> IR.V3U- TVec 4 TWord -> IR.V4U- TMat 2 2 TFloat -> IR.M22F- TMat 2 3 TFloat -> IR.M23F- TMat 2 4 TFloat -> IR.M24F- TMat 3 2 TFloat -> IR.M32F- TMat 3 3 TFloat -> IR.M33F- TMat 3 4 TFloat -> IR.M34F- TMat 4 2 TFloat -> IR.M42F- TMat 4 3 TFloat -> IR.M43F- TMat 4 4 TFloat -> IR.M44F- x -> error $ "compInputType " ++ ppShow x--compAttribute x = case x of- ETuple a -> concatMap compAttribute a- Prim1 "Attribute" (EString s) -> [(s, compInputType $ tyOf x)]- x -> error $ "compAttribute " ++ ppShow x--compAttributeValue :: Exp -> [(IR.InputType,IR.ArrayValue)]-compAttributeValue x = let- compList (A2 "Cons" a x) = compValue a : compList x- compList (A0 "Nil") = []- compList x = error $ "compList: " ++ ppShow x- emptyArray t | t `elem` [IR.Float,IR.V2F,IR.V3F,IR.V4F,IR.M22F,IR.M23F,IR.M24F,IR.M32F,IR.M33F,IR.M34F,IR.M42F,IR.M43F,IR.M44F] = IR.VFloatArray mempty- emptyArray t | t `elem` [IR.Int,IR.V2I,IR.V3I,IR.V4I] = IR.VIntArray mempty- emptyArray t | t `elem` [IR.Word,IR.V2U,IR.V3U,IR.V4U] = IR.VWordArray mempty- emptyArray t | t `elem` [IR.Bool,IR.V2B,IR.V3B,IR.V4B] = IR.VBoolArray mempty- emptyArray _ = error "compAttributeValue - emptyArray"- flatten IR.Float (IR.VFloat x) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> l- flatten IR.V2F (IR.VV2F (IR.V2 x y)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> l- flatten IR.V3F (IR.VV3F (IR.V3 x y z)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> pure z <> l- flatten IR.V4F (IR.VV4F (IR.V4 x y z w)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> pure z <> pure w <> l- flatten _ _ _ = error "compAttributeValue"- checkLength l@((a,_):_) = case all (\(i,_) -> i == a) l of- True -> snd $ unzip l- False -> error "FetchArrays array length mismatch!"- go = \case- ETuple a -> concatMap go a- a -> let A1 "List" (compInputType -> t) = tyOf a- values = compList a- in- [(length values,(t,foldr (flatten t) (emptyArray t) values))]- in checkLength $ go x--compFetchPrimitive x = case x of- A0 "Point" -> IR.Points- A0 "Line" -> IR.Lines- A0 "Triangle" -> IR.Triangles- A0 "LineAdjacency" -> IR.LinesAdjacency- A0 "TriangleAdjacency" -> IR.TrianglesAdjacency- x -> error $ "compFetchPrimitive " ++ ppShow x--compValue x = case x of- EFloat a -> IR.VFloat $ realToFrac a- EInt a -> IR.VInt $ fromIntegral a- A2 "V2" (EFloat a) (EFloat b) -> IR.VV2F $ IR.V2 (realToFrac a) (realToFrac b)- A3 "V3" (EFloat a) (EFloat b) (EFloat c) -> IR.VV3F $ IR.V3 (realToFrac a) (realToFrac b) (realToFrac c)- A4 "V4" (EFloat a) (EFloat b) (EFloat c) (EFloat d) -> IR.VV4F $ IR.V4 (realToFrac a) (realToFrac b) (realToFrac c) (realToFrac d)- A2 "V2" (EBool a) (EBool b) -> IR.VV2B $ IR.V2 a b- A3 "V3" (EBool a) (EBool b) (EBool c) -> IR.VV3B $ IR.V3 a b c- A4 "V4" (EBool a) (EBool b) (EBool c) (EBool d) -> IR.VV4B $ IR.V4 a b c d- x -> error $ "compValue " ++ ppShow x--compRC x = case x of- A3 "PointCtx" a (EFloat b) c -> IR.PointCtx (compPS a) (realToFrac b) (compPSCO c)- A2 "LineCtx" (EFloat a) b -> IR.LineCtx (realToFrac a) (compPV b)- A4 "TriangleCtx" a b c d -> IR.TriangleCtx (compCM a) (compPM b) (compPO c) (compPV d)- x -> error $ "compRC " ++ ppShow x--compRC' x = case x of- A3 "PointCtx" a _ _ -> compPS' a- A4 "TriangleCtx" _ b _ _ -> compPM' b- x -> defaultPointSizeFun $ case tyOf x of A2 "RasterContext" t _ -> t--compPSCO x = case x of- A0 "LowerLeft" -> IR.LowerLeft- A0 "UpperLeft" -> IR.UpperLeft- x -> error $ "compPSCO " ++ ppShow x--compCM x = case x of- A0 "CullNone" -> IR.CullNone- A0 "CullFront" -> IR.CullFront IR.CCW- A0 "CullBack" -> IR.CullBack IR.CCW- x -> error $ "compCM " ++ ppShow x--compPM x = case x of- A0 "PolygonFill" -> IR.PolygonFill- A1 "PolygonLine" (EFloat a) -> IR.PolygonLine $ realToFrac a- A1 "PolygonPoint" a -> IR.PolygonPoint $ compPS a- x -> error $ "compPM " ++ ppShow x--compPM' x = case x of- A1 "PolygonPoint" a -> compPS' a- x -> defaultPointSizeFun $ case tyOf x of A1 "PolygonMode" t -> t--compPS x = case x of- A1 "PointSize" (EFloat a) -> IR.PointSize $ realToFrac a- A1 "ProgramPointSize" _ -> IR.ProgramPointSize- x -> error $ "compPS " ++ ppShow x--compPS' x = case x of- A1 "ProgramPointSize" x -> x- x -> defaultPointSizeFun $ case tyOf x of A1 "PointSize" t -> t--compPO x = case x of- A2 "Offset" (EFloat a) (EFloat b) -> IR.Offset (realToFrac a) (realToFrac b)- A0 "NoOffset" -> IR.NoOffset- x -> error $ "compPO " ++ ppShow x--compPV x = case x of- A0 "FirstVertex" -> IR.FirstVertex- A0 "LastVertex" -> IR.LastVertex- x -> error $ "compPV " ++ ppShow x----------------------------------------------------------------- GLSL generation--{--mangleIdent :: String -> String-mangleIdent n = '_': concatMap encodeChar n- where- encodeChar = \case- c | isAlphaNum c -> [c]- '_' -> "__"- '.' -> "_dot"- '$' -> "_dollar"- '~' -> "_tilde"- '=' -> "_eq"- '<' -> "_less"- '>' -> "_greater"- '!' -> "_bang"- '#' -> "_hash"- '%' -> "_percent"- '^' -> "_up"- '&' -> "_amp"- '|' -> "_bar"- '*' -> "_times"- '/' -> "_div"- '+' -> "_plus"- '-' -> "_minus"- ':' -> "_colon"- '\\' -> "_bslash"- '?' -> "_qmark"- '@' -> "_at"- '\'' -> "_prime"- c -> '$' : show (ord c)--}--genUniforms :: Exp -> Set [String]-genUniforms e = case e of- Uniform s -> Set.singleton [unwords ["uniform",toGLSLType "1" $ tyOf e,s,";"]]- ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]- ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> Set.singleton [unwords ["uniform","sampler2D",n,";"]]- Exp e -> foldMap genUniforms e--type GLSL = Writer [String]--genStreamInput :: Backend -> Pat -> GLSL [String]-genStreamInput backend i = fmap concat $ mapM input $ case i of- PTuple l -> l- x -> [x]- where- input (PVar t n) = tell [unwords [inputDef,toGLSLType (n ++ " " ++ "\n") t,n,";"]] >> return [n]- input a = error $ "genStreamInput " ++ ppShow a- inputDef = case backend of- OpenGL33 -> "in"- WebGL1 -> "attribute"--streamInput :: Pat -> [String]-streamInput i = concatMap input $ case i of- PTuple l -> l- x -> [x]- where- input (PVar t n) = [n]- input a = error $ "streamInput " ++ ppShow a--genStreamOutput :: Backend -> Exp -> [Exp] -> GLSL [(String, String, String)]-genStreamOutput backend (eTuple -> is) l = fmap concat $ zipWithM go (map (("vv" ++) . show) [0..]) $ zip is l- where- go var (A0 (f -> i), toGLSLType "3" . tyOf -> t) = do- tell $ case backend of- WebGL1 -> [unwords ["varying",t,var,";"]]- OpenGL33 -> [unwords [i,"out",t,var,";"]]- return [(i,t,var)]- f "Smooth" = "smooth"- f "Flat" = "flat"- f "NoPerspective" = "noperspective"--eTuple (ETuple l) = l-eTuple x = [x]--genFragmentInput :: Backend -> [(String, String, String)] -> GLSL ()-genFragmentInput OpenGL33 s = tell [unwords [i,"in",t,n,";"] | (i,t,n) <- s]-genFragmentInput WebGL1 s = tell [unwords ["varying",t,n,";"] | (i,t,n) <- s]-genFragmentOutput backend (tyOf -> a@(toGLSLType "4" -> t)) = case a of- TUnit -> return False- _ -> case backend of- OpenGL33 -> tell [unwords ["out",t,"f0",";"]] >> return True- WebGL1 -> return True--shaderHeader = \case- OpenGL33 -> do- tell ["#version 330 core"]- tell ["vec4 texture2D(sampler2D s, vec2 uv){return texture(s,uv);}"]- WebGL1 -> do- tell ["#version 100"]- tell ["precision highp float;"]- tell ["precision highp int;"]--defaultPointSizeFun t = ELam (PVar t "dps") $ EFloat 1--genVertexGLSL :: Backend -> Exp -> Exp -> Exp -> (([String],[(String,String,String)]),String)-genVertexGLSL backend rp@(etaRed -> ELam is s) ints e@(etaRed -> ELam i o) = second unlines $ runWriter $ do- shaderHeader backend- mapM_ tell $ foldMap genUniforms [e, rp]- input <- genStreamInput backend i- out <- genStreamOutput backend ints $ tail $ eTuple o- tell ["void main() {"]- unless (null out) $ sequence_ [tell [var <> " = " <> genGLSL x <> ";"] | ((_,_,var),x) <- zip out $ tail $ eTuple o]- tell ["gl_Position = " <> genGLSL (head $ eTuple o) <> ";"]- tell ["gl_PointSize = " <> show (genGLSLSubst (Map.fromList $ zip (streamInput is) $ map (\(_,_,var) -> var) out) s) <> ";"]- tell ["}"]- return (input,out)-genVertexGLSL _ _ _ e = error $ "genVertexGLSL: " ++ ppShow e--genGLSL :: Exp -> String-genGLSL e = show $ genGLSLSubst mempty e--genFragmentGLSL :: Backend -> Map String IR.InputType -> [(String,String,String)] -> Exp -> Maybe Exp -> String-genFragmentGLSL backend unifs s e@(etaRed -> ELam i o) ffilter = unlines $ execWriter $ do- shaderHeader backend- mapM_ tell $ foldMap genUniforms $ maybe [e] ((e:) . (:[])) ffilter -- todo: use unifs?- genFragmentInput backend s- hasOutput <- genFragmentOutput backend o- tell ["void main() {"]- case ffilter of- Nothing -> return ()- Just (etaRed -> ELam i o) -> tell ["if (!(" <> show (genGLSLSubst (makeSubst i s) o) <> ")) discard;"]- when hasOutput $ case backend of- OpenGL33 -> tell ["f0 = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]- WebGL1 -> tell ["gl_FragColor = " <> show (genGLSLSubst (makeSubst i s) o) <> ";"]- tell ["}"]--genFragmentGLSL _ _ _ e ff = error $ "genFragmentGLSL: " ++ ppShow e ++ ppShow ff--makeSubst (PVar _ x) [(_,_,n)] = Map.singleton x n-makeSubst (PTuple l) x = Map.fromList $ go l x where- go [] [] = []- go (PVar _ x: al) ((_,_,n):bl) = (x,n) : go al bl- go i s = error $ "makeSubst illegal input " ++ ppShow i ++ " " ++ show s--parens a = "(" <+> a <+> ")"---- todo: (on hold) name mangling to prevent name collisions--- todo: reader monad-genGLSLSubst :: Map String String -> Exp -> Doc-genGLSLSubst s e = case e of- ELit a -> text $ show a- EVar a -> text $ Map.findWithDefault a a s- Uniform s -> text s- -- texturing- A3 "Sampler" _ _ _ -> error "sampler GLSL codegen is not supported"- PrimN "texture2D" xs -> functionCall "texture2D" xs-- -- temp builtins FIXME: get rid of these- Prim1 "primIntToWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e- Prim1 "primIntToFloat" a -> gen a -- FIXME: does GLSL support implicit int to float cast???- Prim2 "primCompareInt" a b -> error $ "GLSL codegen does not support: " ++ ppShow e- Prim2 "primCompareWord" a b -> error $ "GLSL codegen does not support: " ++ ppShow e- Prim2 "primCompareFloat" a b -> error $ "GLSL codegen does not support: " ++ ppShow e- Prim1 "primNegateInt" a -> text "-" <+> parens (gen a)- Prim1 "primNegateWord" a -> error $ "WebGL 1 does not support uint types: " ++ ppShow e- Prim1 "primNegateFloat" a -> text "-" <+> parens (gen a)-- -- vectors- AN n xs | n `elem` ["V2", "V3", "V4"], Just s <- vecConName $ tyOf e -> functionCall s xs- -- bool- A0 "True" -> text "true"- A0 "False" -> text "false"- -- matrices- AN "M22F" xs -> functionCall "mat2" xs- AN "M23F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M24F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M32F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M33F" xs -> functionCall "mat3" xs- AN "M34F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M42F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M43F" xs -> error "WebGL 1 does not support matrices with this dimension"- AN "M44F" xs -> functionCall "mat4" xs -- where gen = gen-- Prim3 "primIfThenElse" a b c -> gen a <+> "?" <+> gen b <+> ":" <+> gen c- -- TODO: Texture Lookup Functions- SwizzProj a x -> "(" <+> gen a <+> (")." <> text x)- ELam _ _ -> error "GLSL codegen for lambda function is not supported yet"- ELet (PVar _ _) (A3 "Sampler" _ _ (A1 "Texture2DSlot" (EString n))) _ -> text n- ELet (PVar _ n) (A3 "Sampler" _ _ (A2 "Texture2D" _ _)) _ -> text n- ELet{} -> error "GLSL codegen for let is not supported yet"- ETuple _ -> error "GLSL codegen for tuple is not supported yet"-- -- Primitive Functions- PrimN "==" xs -> binOp "==" xs- PrimN ('P':'r':'i':'m':n) xs | n'@(_:_) <- trName (dropS n) -> case n' of- (c:_) | isAlpha c -> functionCall n' xs- [op, '_'] -> prefixOp [op] xs- n' -> binOp n' xs- where- ifType p a b = if all (p . tyOf) xs then a else b-- dropS n- | last n == 'S' && init n `elem` ["Add", "Sub", "Div", "Mod", "BAnd", "BOr", "BXor", "BShiftL", "BShiftR", "Min", "Max", "Clamp", "Mix", "Step", "SmoothStep"] = init n- | otherwise = n-- trName = \case-- -- Arithmetic Functions- "Add" -> "+"- "Sub" -> "-"- "Neg" -> "-_"- "Mul" -> ifType isMatrix "matrixCompMult" "*"- "MulS" -> "*"- "Div" -> "/"- "Mod" -> ifType isIntegral "%" "mod"-- -- Bit-wise Functions- "BAnd" -> "&"- "BOr" -> "|"- "BXor" -> "^"- "BNot" -> "~_"- "BShiftL" -> "<<"- "BShiftR" -> ">>"-- -- Logic Functions- "And" -> "&&"- "Or" -> "||"- "Xor" -> "^"- "Not" -> ifType isScalar "!_" "not"-- -- Integer/Float Conversion Functions- "FloatBitsToInt" -> "floatBitsToInt"- "FloatBitsToUInt" -> "floatBitsToUint"- "IntBitsToFloat" -> "intBitsToFloat"- "UIntBitsToFloat" -> "uintBitsToFloat"-- -- Matrix Functions- "OuterProduct" -> "outerProduct"- "MulMatVec" -> "*"- "MulVecMat" -> "*"- "MulMatMat" -> "*"-- -- Fragment Processing Functions- "DFdx" -> "dFdx"- "DFdy" -> "dFdy"-- -- Vector and Scalar Relational Functions- "LessThan" -> ifType isScalarNum "<" "lessThan"- "LessThanEqual" -> ifType isScalarNum "<=" "lessThanEqual"- "GreaterThan" -> ifType isScalarNum ">" "greaterThan"- "GreaterThanEqual" -> ifType isScalarNum ">=" "greaterThanEqual"- "Equal" -> "=="- "EqualV" -> ifType isScalar "==" "equal"- "NotEqual" -> "!="- "NotEqualV" -> ifType isScalar "!=" "notEqual"-- -- Angle and Trigonometry Functions- "ATan2" -> "atan"- -- Exponential Functions- "InvSqrt" -> "inversesqrt"- -- Common Functions- "RoundEven" -> "roundEven"- "ModF" -> error "PrimModF is not implemented yet!" -- TODO- "MixB" -> "mix"-- n | n `elem`- -- Logic Functions- [ "Any", "All"- -- Angle and Trigonometry Functions- , "ACos", "ACosH", "ASin", "ASinH", "ATan", "ATanH", "Cos", "CosH", "Degrees", "Radians", "Sin", "SinH", "Tan", "TanH"- -- Exponential Functions- , "Pow", "Exp", "Exp2", "Log2", "Sqrt"- -- Common Functions- , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Step", "SmoothStep"- -- Geometric Functions- , "Length", "Distance", "Dot", "Cross", "Normalize", "FaceForward", "Reflect", "Refract"- -- Matrix Functions- , "Transpose", "Determinant", "Inverse"- -- Fragment Processing Functions- , "FWidth"- -- Noise Functions- , "Noise1", "Noise2", "Noise3", "Noise4"- ] -> map toLower n-- _ -> ""-- x -> error $ "GLSL codegen - unsupported expression: " ++ ppShow x- where- prefixOp o [a] = text o <+> parens (gen a)- binOp o [a, b] = parens (gen a) <+> text o <+> parens (gen b)- functionCall f a = text f <+> parens (hcat $ intersperse "," $ map gen a)-- gen = genGLSLSubst s--isMatrix :: Ty -> Bool-isMatrix TMat{} = True-isMatrix _ = False--isIntegral :: Ty -> Bool-isIntegral TWord = True-isIntegral TInt = True-isIntegral (TVec _ TWord) = True-isIntegral (TVec _ TInt) = True-isIntegral _ = False--isScalarNum :: Ty -> Bool-isScalarNum = \case- TInt -> True- TWord -> True- TFloat -> True- _ -> False--isScalar :: Ty -> Bool-isScalar = isJust . scalarType--scalarType = \case- TBool -> Just "b"- TWord -> Just "u"- TInt -> Just "i"- TFloat -> Just ""- _ -> Nothing--vecConName = \case- TVec n t | is234 n, Just s <- scalarType t -> Just $ s ++ "vec" ++ show n- t -> Nothing--toGLSLType msg = \case- TBool -> "bool"- TWord -> "uint"- TInt -> "int"- TFloat -> "float"- x@(TVec n t) | Just s <- vecConName x -> s- TMat i j TFloat | is234 i && is234 j -> "mat" ++ if i == j then show i else show i ++ "x" ++ show j- TTuple [] -> "void"- t -> error $ "toGLSLType: " ++ msg ++ " " ++ ppShow t--is234 = (`elem` [2,3,4])-------------------------------------------------------------------------------------data Exp_ a- = Pi_ Visibility SName a a- | Lam_ Visibility Pat a a- | Con_ SName a [a]- | ELit_ Lit- | Fun_ SName a [a]- | App_ a a- | Var_ SName a- | TType_- | Let_ Pat a a- deriving (Show, Eq, Functor, Foldable, Traversable)--instance PShow Exp where- pShowPrec p = \case- Var n t -> text n- TType -> "Type"- ELit a -> text $ show a- Con n t ps -> pApps p (text n) ps- Fun n t ps -> pApps p (text n) ps- EApp a b -> pApp p a b- Lam h n t e -> pParens True $ "\\" <> showVis h <> pShow n </> "->" <+> pShow e- Pi h n t e -> pParens True $ showVis h <> pShow n </> "->" <+> pShow e- ELet pat x e -> pParens (p > 0) $ "let" <+> pShow pat </> "=" <+> pShow x </> "in" <+> pShow e- where- showVis Visible = ""- showVis Hidden = "@"--pattern Pi h n a b = Exp (Pi_ h n a b)-pattern Lam h n a b = Exp (Lam_ h n a b)-pattern Con n a b = Exp (Con_ (UntickName n) a b)-pattern ELit a = Exp (ELit_ a)-pattern Fun n a b = Exp (Fun_ (UntickName n) a b)-pattern EApp a b = Exp (App_ a b)-pattern Var a b = Exp (Var_ a b)-pattern TType = Exp TType_-pattern ELet a b c = Exp (Let_ a b c)--pattern UntickName n <- (untick -> n) where UntickName = untick--pattern EString s = ELit (LString s)-pattern EFloat s = ELit (LFloat s)-pattern EInt s = ELit (LInt s)--newtype Exp = Exp (Exp_ Exp)- deriving (Show, Eq)--makeTE [] = I.EGlobal (error "makeTE - no source") I.initEnv $ error "makeTE"-makeTE ((_, t): vs) = I.EBind2 (I.BLam Visible) t $ makeTE vs--toExp :: I.ExpType -> Exp-toExp = flip runReader [] . flip evalStateT freshTypeVars . f_- where- freshTypeVars = flip (:) <$> map show [0..] <*> ['a'..'z']- newName = gets head <* modify tail- f_ (e, et)- | isSampler et = newName >>= \n -> do- t <- f_ (et, I.TType)- ELet (PVar t n) <$> f__ (e, et) <*> pure (Var n t)- | otherwise = f__ (e, et)- f__ (e, et) = case e of- I.Var i -> asks $ fst . (!!! i)- I.Pi b x (I.down 0 -> Just y) -> Pi b "" <$> f_ (x, I.TType) <*> f_ (y, I.TType)- I.Pi b x y -> newName >>= \n -> do- t <- f_ (x, I.TType)- Pi b n t <$> local ((Var n t, x):) (f_ (y, I.TType))- I.Lam y -> case et of- I.Pi b x yt -> newName >>= \n -> do- t <- f_ (x, I.TType)- Lam b (PVar t n) t <$> local ((Var n t, x):) (f_ (y, yt))- I.Con s n xs -> Con (show s) <$> f_ (I.nType s, I.TType) <*> chain [] (I.nType s) (I.mkConPars n et ++ xs)- I.TyCon s xs -> Con (show s) <$> f_ (I.nType s, I.TType) <*> chain [] (I.nType s) xs- I.Fun s xs -> Fun (show s) <$> f_ (I.nType s, I.TType) <*> chain [] (I.nType s) xs- I.CaseFun s xs n -> asks makeTE >>= \te -> Fun (show s) <$> f_ (I.nType s, I.TType) <*> chain [] (I.nType s) (I.makeCaseFunPars te n ++ xs ++ [I.Neut n])- I.Neut (I.App_ a b) -> asks makeTE >>= \te -> do- let t = I.neutType te a- app' <$> f_ (I.Neut a, t) <*> (head <$> chain [] t [b])- I.ELit l -> pure $ ELit l- I.TType -> pure TType- x@I.PMLabel{} -> f_ (I.unpmlabel x, et)- I.FixLabel _ x -> f_ (x, et)--- I.LabelEnd x -> f x -- not possible- z -> error $ "toExp: " ++ show z-- chain acc t [] = return $ reverse acc- chain acc t@(I.Pi b at y) (a: as) = do- a' <- f_ (a, at)- chain (a': acc) (I.appTy t a) as-- xs !!! i | i < 0 || i >= length xs = error $ show xs ++ " !! " ++ show i- xs !!! i = xs !! i--isSampler (I.TyCon n _) = show n == "'Sampler"-isSampler _ = False--untick ('\'': s) = s-untick s = s--freeVars :: Exp -> Set.Set SName-freeVars = \case- Var n _ -> Set.singleton n- Con _ _ xs -> mconcat $ map freeVars xs- ELit _ -> mempty- Fun _ _ xs -> mconcat $ map freeVars xs- EApp a b -> freeVars a <> freeVars b- Pi _ n a b -> freeVars a <> Set.delete n (freeVars b)- Lam _ n a b -> freeVars a <> foldr Set.delete (freeVars b) (patVars n)- TType -> mempty- ELet n a b -> freeVars a <> foldr Set.delete (freeVars b) (patVars n)--type Ty = Exp--tyOf :: Exp -> Ty-tyOf = \case- Lam h (PVar _ n) t x -> Pi h n t $ tyOf x- EApp f x -> app (tyOf f) x- Var _ t -> t- Pi{} -> TType- Con _ t xs -> foldl app t xs- Fun _ t xs -> foldl app t xs- ELit l -> toExp (I.litType l, I.TType)- TType -> TType- ELet a b c -> tyOf $ EApp (ELam a c) b- x -> error $ "tyOf: " ++ ppShow x- where- app (Pi _ n a b) x = substE n x b--substE n x = \case- z@(Var n' _) | n' == n -> x- | otherwise -> z - Pi h n' a b | n == n' -> Pi h n' (substE n x a) b- Pi h n' a b -> Pi h n' (substE n x a) (substE n x b)- Lam h n' a b -> Lam h n' (substE n x a) $ if n `elem` patVars n' then b else substE n x b- Con n' cn xs -> Con n' cn (map (substE n x) xs)- Fun n' cn xs -> Fun n' cn (map (substE n x) xs)- TType -> TType- EApp a b -> app' (substE n x a) (substE n x b)- x@ELit{} -> x- z -> error $ "substE: " ++ ppShow z--app' (Lam _ (PVar _ n) _ x) b = substE n b x-app' a b = EApp a b---------------------------------------------------------------------------------- Exp conversion -- TODO: remove--data Pat- = PVar Exp SName- | PTuple [Pat]- deriving (Eq, Show)--instance PShow Pat where- pShowPrec p = \case- PVar t n -> text n- PTuple ps -> tupled $ map pShow ps--patVars (PVar _ n) = [n]-patVars (PTuple ps) = concatMap patVars ps--patTy (PVar t _) = t-patTy (PTuple ps) = Con ("Tuple" ++ show (length ps)) (tupTy $ length ps) $ map patTy ps--tupTy n = foldr (:~>) TType $ replicate n TType---- workaround for backward compatibility-etaRed (ELam (PVar _ n) (EApp f (EVar n'))) | n == n' && n `Set.notMember` freeVars f = f-etaRed (ELam (PVar _ n) (Prim3 (tupCaseName -> Just k) _ x (EVar n'))) | n == n' && n `Set.notMember` freeVars x = uncurry (\ps e -> ELam (PTuple ps) e) $ getPats k x-etaRed x = x--pattern EtaPrim1 s <- (getEtaPrim -> Just (s, []))-pattern EtaPrim2 s x <- (getEtaPrim -> Just (s, [x]))-pattern EtaPrim3 s x1 x2 <- (getEtaPrim -> Just (s, [x1, x2]))-pattern EtaPrim4 s x1 x2 x3 <- (getEtaPrim -> Just (s, [x1, x2, x3]))-pattern EtaPrim5 s x1 x2 x3 x4 <- (getEtaPrim -> Just (s, [x1, x2, x3, x4]))-pattern EtaPrim2_2 s <- (getEtaPrim2 -> Just (s, []))--getEtaPrim (ELam (PVar _ n) (PrimN s (initLast -> Just (xs, EVar n')))) | n == n' && all (Set.notMember n . freeVars) xs = Just (s, xs)-getEtaPrim _ = Nothing--getEtaPrim2 (ELam (PVar _ n) (ELam (PVar _ n2) (PrimN s (initLast -> Just (initLast -> Just (xs, EVar n'), EVar n2'))))) | n == n' && n2 == n2' && all (Set.notMember n . freeVars) xs = Just (s, xs)-getEtaPrim2 _ = Nothing--initLast [] = Nothing-initLast xs = Just (init xs, last xs)--tupCaseName "Tuple2Case" = Just 2-tupCaseName "Tuple3Case" = Just 3-tupCaseName "Tuple4Case" = Just 4-tupCaseName "Tuple5Case" = Just 5-tupCaseName "Tuple6Case" = Just 6-tupCaseName "Tuple7Case" = Just 7-tupCaseName _ = Nothing--getPats 0 e = ([], e)-getPats i (ELam p e) = first (p:) $ getPats (i-1) e-----------------pattern EVar n <- Var n _--pattern ELam n b <- Lam Visible n _ b where ELam n b = Lam Visible n (patTy n) b--idFun t = Lam Visible (PVar t n) t (Var n t) where n = "id"--pattern a :~> b = Pi Visible "" a b-infixr 1 :~>--pattern PrimN n xs <- Fun n t (filterRelevant (n, 0) t -> xs) where PrimN n xs = Fun n (builtinType n) xs-pattern Prim1 n a = PrimN n [a]-pattern Prim2 n a b = PrimN n [a, b]-pattern Prim3 n a b c <- PrimN n [a, b, c]-pattern Prim4 n a b c d <- PrimN n [a, b, c, d]-pattern Prim5 n a b c d e <- PrimN n [a, b, c, d, e]--builtinType = \case- "Output" -> TType- "Bool" -> TType- "Float" -> TType- "Nat" -> TType- "Zero" -> TNat- "Succ" -> TNat :~> TNat- "String" -> TType- "Sampler" -> TType- "VecS" -> TType :~> TNat :~> TType- n -> error $ "type of " ++ ppShow n--filterRelevant _ _ [] = []-filterRelevant i (Pi h n t t') (x: xs) = (if h == Visible then (x:) else id) $ filterRelevant (second (+1) i) (substE n x t') xs--pattern AN n xs <- Con n t (filterRelevant (n, 0) t -> xs) where AN n xs = Con n (builtinType n) xs-pattern A0 n = AN n []-pattern A1 n a = AN n [a]-pattern A2 n a b = AN n [a, b]-pattern A3 n a b c <- AN n [a, b, c]-pattern A4 n a b c d <- AN n [a, b, c, d]-pattern A5 n a b c d e <- AN n [a, b, c, d, e]--pattern TCon0 n = A0 n-pattern TCon t n = Con n t []--pattern TUnit <- A0 "Tuple0"-pattern TBool = A0 "Bool"-pattern TWord <- A0 "Word"-pattern TInt <- A0 "Int"-pattern TNat = A0 "Nat"-pattern TFloat = A0 "Float"-pattern TString = A0 "String"--pattern Uniform n <- Prim1 "Uniform" (EString n)--pattern Zero = A0 "Zero"-pattern Succ n = A1 "Succ" n--pattern TVec n a = A2 "VecS" a (Nat n)-pattern TMat i j a <- A3 "Mat" (Nat i) (Nat j) a--pattern Nat n <- (fromNat -> Just n) where Nat = toNat--toNat :: Int -> Exp-toNat 0 = Zero-toNat n = Succ (toNat $ n-1)--fromNat :: Exp -> Maybe Int-fromNat Zero = Just 0-fromNat (Succ n) = (1 +) <$> fromNat n-fromNat _ = Nothing--pattern TTuple xs <- (getTuple -> Just xs)-pattern ETuple xs <- (getTuple -> Just xs)--getTuple (AN (tupName -> Just n) xs) | length xs == n = Just xs-getTuple _ = Nothing--tupName = \case- "Tuple0" -> Just 0- "Tuple2" -> Just 2- "Tuple3" -> Just 3- "Tuple4" -> Just 4- "Tuple5" -> Just 5- "Tuple6" -> Just 6- "Tuple7" -> Just 7- _ -> Nothing--pattern SwizzProj a b <- (getSwizzProj -> Just (a, b))--getSwizzProj = \case- Prim2 "swizzscalar" e (getSwizzChar -> Just s) -> Just (e, [s])- Prim2 "swizzvector" e (AN ((`elem` ["V2","V3","V4"]) -> True) (traverse getSwizzChar -> Just s)) -> Just (e, s)- _ -> Nothing--getSwizzChar = \case- A0 "Sx" -> Just 'x'- A0 "Sy" -> Just 'y'- A0 "Sz" -> Just 'z'- A0 "Sw" -> Just 'w'- _ -> Nothing+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove+module LambdaCube.Compiler.CoreToIR+ ( compilePipeline+ ) where++import Data.Char+import Data.Monoid+import Data.Map (Map)+import Data.Maybe+import Data.Function+import Data.List+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Vector as Vector+import Control.Arrow hiding ((<+>))+import Control.Monad.Writer+import Control.Monad.State++import LambdaCube.IR(Backend(..))+import qualified LambdaCube.IR as IR+import qualified LambdaCube.Linear as IR++import LambdaCube.Compiler.Pretty+import LambdaCube.Compiler.Infer hiding (Con, Lam, Pi, TType, Var, ELit, Func)+import qualified LambdaCube.Compiler.Infer as I+import LambdaCube.Compiler.Parser (up, Up (..), upDB)++import Data.Version+import Paths_lambdacube_compiler (version)++--------------------------------------------------------------------------++compilePipeline :: IR.Backend -> ExpType -> IR.Pipeline+compilePipeline backend exp = IR.Pipeline+ { IR.info = "generated by lambdacube-compiler " ++ showVersion version+ , IR.backend = backend+ , IR.samplers = mempty+ , IR.programs = Vector.fromList . map fst . sortBy (compare `on` snd) . Map.toList $ programs+ , IR.slots = Vector.fromList . map snd . sortBy (compare `on` fst) . Map.elems $ slots+ , IR.targets = Vector.fromList . reverse . snd $ targets+ , IR.streams = Vector.fromList . reverse . snd $ streams+ , IR.textures = Vector.fromList . reverse . snd $ textures+ , IR.commands = Vector.fromList $ subCmds <> cmds+ }+ where+ ((subCmds,cmds), (streams, programs, targets, slots, textures))+ = flip runState ((0, mempty), mempty, (0, mempty), mempty, (0, mempty)) $ case toExp exp of+ A1 "ScreenOut" a -> addTarget backend a [IR.TargetItem s $ Just $ IR.Framebuffer s | s <- getSemantics a]+ x -> error $ "ScreenOut expected inststead of " ++ ppShow x++type CG = State (List IR.StreamData, Map IR.Program Int, List IR.RenderTarget, Map String (Int, IR.Slot), List IR.TextureDescriptor)++type List a = (Int, [a])++streamLens f (a,b,c,d,e) = f (,b,c,d,e) a+programLens f (a,b,c,d,e) = f (a,,c,d,e) b+targetLens f (a,b,c,d,e) = f (a,b,,d,e) c+slotLens f (a,b,c,d,e) = f (a,b,c,,e) d+textureLens f (a,b,c,d,e) = f (a,b,c,d,) e++modL gs f = state $ gs $ \fx -> second fx . f++addL' l p f x = modL l $ \sv -> maybe (length sv, Map.insert p (length sv, x) sv) (\(i, x') -> (i, Map.insert p (i, f x x') sv)) $ Map.lookup p sv+addL l x = modL l $ \(i, sv) -> (i, (i+1, x: sv))+addLEq l x = modL l $ \sv -> maybe (let i = length sv in i `seq` (i, Map.insert x i sv)) (\i -> (i, sv)) $ Map.lookup x sv++---------------------------------------------------------++addTarget backend a tl = do+ rt <- addL targetLens $ IR.RenderTarget $ Vector.fromList tl+ second (IR.SetRenderTarget rt:) <$> getCommands backend a++getCommands :: Backend -> ExpTV{-FrameBuffer-} -> CG ([IR.Command],[IR.Command])+getCommands backend e = case e of++ A1 "FrameBuffer" (ETuple a) -> return ([], [IR.ClearRenderTarget $ Vector.fromList $ map compFrameBuffer a])++ A3 "Accumulate" actx (getFragmentShader -> (frag, getFragFilter -> (ffilter, x1))) fbuf -> case x1 of++ A3 "foldr" (A0 "++") (A0 "Nil") (A2 "map" (EtaPrim3 "rasterizePrimitive" ints rctx) (getVertexShader -> (vert, input_))) -> mdo++ let + (vertexInput, pUniforms, vertSrc, fragSrc) = genGLSLs backend (compRC' rctx) ints vert frag ffilter++ pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms++ prg = IR.Program+ { IR.programUniforms = pUniforms'+ , IR.programStreams = Map.fromList $ zip vertexInput $ map (uncurry IR.Parameter) input+ , IR.programInTextures = snd <$> Map.filter ((\case UUniform{} -> False; _ -> True) . fst) pUniforms+ , IR.programOutput = pure $ IR.Parameter "f0" IR.V4F -- TODO+ , IR.vertexShader = show vertSrc+ , IR.geometryShader = mempty -- TODO+ , IR.fragmentShader = show fragSrc+ }++ textureUniforms = [IR.SetSamplerUniform n textureUnit | ((n,IR.FTexture2D),textureUnit) <- zip (Map.toList pUniforms') [0..]]+ cmds =+ [ IR.SetProgram prog ] <>+ textureUniforms <>+ concat -- TODO: generate IR.SetSamplerUniform commands for texture slots+ [ [ IR.SetTexture textureUnit texture+ , IR.SetSamplerUniform name textureUnit+ ] | (textureUnit,(name,IR.TextureImage texture _ _)) <- zip [length textureUniforms..] smpBindings+ ] <>+ [ IR.SetRasterContext (compRC rctx)+ , IR.SetAccumulationContext (compAC actx)+ , renderCommand+ ]++ (smpBindings, txtCmds) <- mconcat <$> traverse (uncurry getRenderTextureCommands) (Map.toList $ fst <$> pUniforms)++ (renderCommand,input) <- case input_ of+ A2 "fetch" (EString slotName) attrs -> do+ i <- IR.RenderSlot <$> addL' slotLens slotName (flip mergeSlot) IR.Slot+ { IR.slotName = slotName+ , IR.slotUniforms = IR.programUniforms prg+ , IR.slotPrograms = pure prog+ , IR.slotStreams = Map.fromList input+ , IR.slotPrimitive = compFetchPrimitive $ getPrim $ tyOf input_+ }+ return (i, input)+ where+ input = compInputType'' attrs+ mergeSlot a b = a+ { IR.slotUniforms = IR.slotUniforms a <> IR.slotUniforms b+ , IR.slotStreams = IR.slotStreams a <> IR.slotStreams b+ , IR.slotPrograms = IR.slotPrograms a <> IR.slotPrograms b+ }+ A1 "fetchArrays" (unzip . compAttributeValue -> (tys, values)) -> do+ i <- IR.RenderStream <$> addL streamLens IR.StreamData+ { IR.streamData = Map.fromList $ zip names values+ , IR.streamType = Map.fromList input+ , IR.streamPrimitive = compFetchPrimitive $ getPrim $ tyOf input_+ , IR.streamPrograms = pure prog+ }+ return (i, input)+ where+ names = ["attribute_" ++ show i | i <- [0..]]+ input = zip names tys+ e -> error $ "getSlot: " ++ ppShow e++ prog <- addLEq programLens prg++ (<> (txtCmds, cmds)) <$> getCommands backend fbuf++ x -> error $ "getCommands': " ++ ppShow x+ x -> error $ "getCommands: " ++ ppShow x+ where+ getRenderTextureCommands :: String -> Uniform -> CG ([SamplerBinding],[IR.Command])+ getRenderTextureCommands n = \case+ UTexture2D (fromIntegral -> width) (fromIntegral -> height) img -> do++ let (a, tf) = case img of+ A1 "PrjImageColor" a -> (,) a $ \[_, x] -> x+ A1 "PrjImage" a -> (,) a $ \[x] -> x+ tl <- forM (getSemantics a) $ \semantic -> do+ texture <- addL textureLens IR.TextureDescriptor+ { IR.textureType = IR.Texture2D (if semantic == IR.Color then IR.FloatT IR.RGBA else IR.FloatT IR.Red) 1+ , IR.textureSize = IR.VV2U $ IR.V2 (fromIntegral width) (fromIntegral height)+ , IR.textureSemantic = semantic+ , IR.textureSampler = IR.SamplerDescriptor+ { IR.samplerWrapS = IR.Repeat+ , IR.samplerWrapT = Nothing+ , IR.samplerWrapR = Nothing+ , IR.samplerMinFilter = IR.Linear + , IR.samplerMagFilter = IR.Linear+ , IR.samplerBorderColor = IR.VV4F (IR.V4 0 0 0 1)+ , IR.samplerMinLod = Nothing+ , IR.samplerMaxLod = Nothing+ , IR.samplerLodBias = 0+ , IR.samplerCompareFunc = Nothing+ }+ , IR.textureBaseLevel = 0+ , IR.textureMaxLevel = 0+ }+ return $ IR.TargetItem semantic $ Just $ IR.TextureImage texture 0 Nothing+ (subCmds, cmds) <- addTarget backend a tl+ let (IR.TargetItem IR.Color (Just tx)) = tf tl+ return ([(n, tx)], subCmds ++ cmds)+ _ -> return mempty++type SamplerBinding = (IR.UniformName,IR.ImageRef)++----------------------------------------------------------------++frameBufferType (A2 "FrameBuffer" _ ty) = ty+frameBufferType x = error $ "illegal target type: " ++ ppShow x++getSemantics = compSemantics . frameBufferType . tyOf++getFragFilter (A2 "map" (EtaPrim2 "filterFragment" p) x) = (Just p, x)+getFragFilter x = (Nothing, x)++getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x)+--getVertexShader (A2 "map" (EtaPrim2 "mapPrimitive" f) x) = error $ "gff: " ++ show (case f of ExpTV x _ _ -> x) --ppShow (mapVal unFunc' f)+--getVertexShader x = error $ "gf: " ++ ppShow x+getVertexShader x = ((Nothing, getPrim' $ tyOf x), x)++getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f@(etaReds -> Just (_, o))) x) = ((Just f, tyOf o), x)+--getFragmentShader (A2 "map" (EtaPrim2 "mapFragment" f) x) = error $ "gff: " ++ ppShow f+--getFragmentShader x = error $ "gf: " ++ ppShow x+getFragmentShader x = ((Nothing, getPrim'' $ tyOf x), x)++getPrim (A1 "List" (A2 "Primitive" _ p)) = p+getPrim' (A1 "List" (A2 "Primitive" a _)) = a+getPrim'' (A1 "List" (A2 "Vector" _ (A1 "Maybe" (A1 "SimpleFragment" (TTuple [a]))))) = a+getPrim'' x = error $ "getPrim'':" ++ ppShow x++compFrameBuffer = \case+ A1 "DepthImage" a -> IR.ClearImage IR.Depth $ compValue a+ A1 "ColorImage" a -> IR.ClearImage IR.Color $ compValue a+ x -> error $ "compFrameBuffer " ++ ppShow x++compSemantics = map compSemantic . compList++compList (A2 "Cons" a x) = a : compList x+compList (A0 "Nil") = []+compList x = error $ "compList: " ++ ppShow x++compSemantic = \case+ A0 "Depth" -> IR.Depth+ A0 "Stencil" -> IR.Stencil+ A1 "Color" _ -> IR.Color+ x -> error $ "compSemantic: " ++ ppShow x++compAC (ETuple x) = IR.AccumulationContext Nothing $ map compFrag x++compBlending x = case x of+ A0 "NoBlending" -> IR.NoBlending+ A1 "BlendLogicOp" a -> IR.BlendLogicOp (compLO a)+ A3 "Blend" (ETuple [a,b]) (ETuple [ETuple [c,d],ETuple [e,f]]) (compValue -> IR.VV4F g) -> IR.Blend (compBE a) (compBE b) (compBF c) (compBF d) (compBF e) (compBF f) g+ x -> error $ "compBlending " ++ ppShow x++compBF x = case x of+ A0 "ZeroBF" -> IR.Zero+ A0 "OneBF" -> IR.One+ A0 "SrcColor" -> IR.SrcColor+ A0 "OneMinusSrcColor" -> IR.OneMinusSrcColor+ A0 "DstColor" -> IR.DstColor+ A0 "OneMinusDstColor" -> IR.OneMinusDstColor+ A0 "SrcAlpha" -> IR.SrcAlpha+ A0 "OneMinusSrcAlpha" -> IR.OneMinusSrcAlpha+ A0 "DstAlpha" -> IR.DstAlpha+ A0 "OneMinusDstAlpha" -> IR.OneMinusDstAlpha+ A0 "ConstantColor" -> IR.ConstantColor+ A0 "OneMinusConstantColor" -> IR.OneMinusConstantColor+ A0 "ConstantAlpha" -> IR.ConstantAlpha+ A0 "OneMinusConstantAlpha" -> IR.OneMinusConstantAlpha+ A0 "SrcAlphaSaturate" -> IR.SrcAlphaSaturate+ x -> error $ "compBF " ++ ppShow x++compBE x = case x of+ A0 "FuncAdd" -> IR.FuncAdd+ A0 "FuncSubtract" -> IR.FuncSubtract+ A0 "FuncReverseSubtract" -> IR.FuncReverseSubtract+ A0 "Min" -> IR.Min+ A0 "Max" -> IR.Max+ x -> error $ "compBE " ++ ppShow x++compLO x = case x of+ A0 "Clear" -> IR.Clear+ A0 "And" -> IR.And+ A0 "AndReverse" -> IR.AndReverse+ A0 "Copy" -> IR.Copy+ A0 "AndInverted" -> IR.AndInverted+ A0 "Noop" -> IR.Noop+ A0 "Xor" -> IR.Xor+ A0 "Or" -> IR.Or+ A0 "Nor" -> IR.Nor+ A0 "Equiv" -> IR.Equiv+ A0 "Invert" -> IR.Invert+ A0 "OrReverse" -> IR.OrReverse+ A0 "CopyInverted" -> IR.CopyInverted+ A0 "OrInverted" -> IR.OrInverted+ A0 "Nand" -> IR.Nand+ A0 "Set" -> IR.Set+ x -> error $ "compLO " ++ ppShow x++compComparisonFunction x = case x of+ A0 "Never" -> IR.Never+ A0 "Less" -> IR.Less+ A0 "Equal" -> IR.Equal+ A0 "Lequal" -> IR.Lequal+ A0 "Greater" -> IR.Greater+ A0 "Notequal" -> IR.Notequal+ A0 "Gequal" -> IR.Gequal+ A0 "Always" -> IR.Always+ x -> error $ "compComparisonFunction " ++ ppShow x++pattern EBool a <- (compBool -> Just a)++compBool x = case x of+ A0 "True" -> Just True+ A0 "False" -> Just False+ x -> Nothing++compFrag x = case x of+ A2 "DepthOp" (compComparisonFunction -> a) (EBool b) -> IR.DepthOp a b+ A2 "ColorOp" (compBlending -> b) (compValue -> v) -> IR.ColorOp b v+ x -> error $ "compFrag " ++ ppShow x++toGLSLType msg x = showGLSLType msg $ compInputType msg x++-- move to lambdacube-ir?+showGLSLType msg = \case+ IR.Bool -> "bool"+ IR.Word -> "uint"+ IR.Int -> "int"+ IR.Float -> "float"+ IR.V2F -> "vec2"+ IR.V3F -> "vec3"+ IR.V4F -> "vec4"+ IR.V2B -> "bvec2"+ IR.V3B -> "bvec3"+ IR.V4B -> "bvec4"+ IR.V2U -> "uvec2"+ IR.V3U -> "uvec3"+ IR.V4U -> "uvec4"+ IR.V2I -> "ivec2"+ IR.V3I -> "ivec3"+ IR.V4I -> "ivec4"+ IR.M22F -> "mat2"+ IR.M33F -> "mat3"+ IR.M44F -> "mat4"+ IR.M23F -> "mat2x3"+ IR.M24F -> "mat2x4"+ IR.M32F -> "mat3x2"+ IR.M34F -> "mat3x4"+ IR.M42F -> "mat4x2"+ IR.M43F -> "mat4x3"+ IR.FTexture2D -> "sampler2D"+ t -> error $ "toGLSLType: " ++ msg ++ " " ++ show t++supType = isJust . compInputType_++compInputType_ x = case x of+ TFloat -> Just IR.Float+ TVec 2 TFloat -> Just IR.V2F+ TVec 3 TFloat -> Just IR.V3F+ TVec 4 TFloat -> Just IR.V4F+ TBool -> Just IR.Bool+ TVec 2 TBool -> Just IR.V2B+ TVec 3 TBool -> Just IR.V3B+ TVec 4 TBool -> Just IR.V4B+ TInt -> Just IR.Int+ TVec 2 TInt -> Just IR.V2I+ TVec 3 TInt -> Just IR.V3I+ TVec 4 TInt -> Just IR.V4I+ TWord -> Just IR.Word+ TVec 2 TWord -> Just IR.V2U+ TVec 3 TWord -> Just IR.V3U+ TVec 4 TWord -> Just IR.V4U+ TMat 2 2 TFloat -> Just IR.M22F+ TMat 2 3 TFloat -> Just IR.M23F+ TMat 2 4 TFloat -> Just IR.M24F+ TMat 3 2 TFloat -> Just IR.M32F+ TMat 3 3 TFloat -> Just IR.M33F+ TMat 3 4 TFloat -> Just IR.M34F+ TMat 4 2 TFloat -> Just IR.M42F+ TMat 4 3 TFloat -> Just IR.M43F+ TMat 4 4 TFloat -> Just IR.M44F+ _ -> Nothing++compInputType msg x = fromMaybe (error $ "compInputType " ++ msg ++ " " ++ ppShow x) $ compInputType_ x++is234 = (`elem` [2,3,4])++compInputType'' (ETuple attrs) = map compAttribute attrs++compAttribute = \case+ x@(A1 "Attribute" (EString s)) -> (s, compInputType "compAttr" $ tyOf x)+ x -> error $ "compAttribute " ++ ppShow x++compAttributeValue :: ExpTV -> [(IR.InputType,IR.ArrayValue)]+compAttributeValue (ETuple x) = checkLength $ map go x+ where+ emptyArray t | t `elem` [IR.Float,IR.V2F,IR.V3F,IR.V4F,IR.M22F,IR.M23F,IR.M24F,IR.M32F,IR.M33F,IR.M34F,IR.M42F,IR.M43F,IR.M44F] = IR.VFloatArray mempty+ emptyArray t | t `elem` [IR.Int,IR.V2I,IR.V3I,IR.V4I] = IR.VIntArray mempty+ emptyArray t | t `elem` [IR.Word,IR.V2U,IR.V3U,IR.V4U] = IR.VWordArray mempty+ emptyArray t | t `elem` [IR.Bool,IR.V2B,IR.V3B,IR.V4B] = IR.VBoolArray mempty+ emptyArray _ = error "compAttributeValue - emptyArray"++ flatten IR.Float (IR.VFloat x) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> l+ flatten IR.V2F (IR.VV2F (IR.V2 x y)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> l+ flatten IR.V3F (IR.VV3F (IR.V3 x y z)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> pure z <> l+ flatten IR.V4F (IR.VV4F (IR.V4 x y z w)) (IR.VFloatArray l) = IR.VFloatArray $ pure x <> pure y <> pure z <> pure w <> l+ flatten _ _ _ = error "compAttributeValue"++ checkLength l@((a,_):_) = case all (\(i,_) -> i == a) l of+ True -> snd $ unzip l+ False -> error "FetchArrays array length mismatch!"++ go a = (length values,(t,foldr (flatten t) (emptyArray t) values))+ where (A1 "List" (compInputType "compAV" -> t)) = tyOf a+ values = map compValue $ compList a++compFetchPrimitive x = case x of+ A0 "Point" -> IR.Points+ A0 "Line" -> IR.Lines+ A0 "Triangle" -> IR.Triangles+ A0 "LineAdjacency" -> IR.LinesAdjacency+ A0 "TriangleAdjacency" -> IR.TrianglesAdjacency+ x -> error $ "compFetchPrimitive " ++ ppShow x++compValue x = case x of+ EFloat a -> IR.VFloat $ realToFrac a+ EInt a -> IR.VInt $ fromIntegral a+ A2 "V2" (EFloat a) (EFloat b) -> IR.VV2F $ IR.V2 (realToFrac a) (realToFrac b)+ A3 "V3" (EFloat a) (EFloat b) (EFloat c) -> IR.VV3F $ IR.V3 (realToFrac a) (realToFrac b) (realToFrac c)+ A4 "V4" (EFloat a) (EFloat b) (EFloat c) (EFloat d) -> IR.VV4F $ IR.V4 (realToFrac a) (realToFrac b) (realToFrac c) (realToFrac d)+ A2 "V2" (EBool a) (EBool b) -> IR.VV2B $ IR.V2 a b+ A3 "V3" (EBool a) (EBool b) (EBool c) -> IR.VV3B $ IR.V3 a b c+ A4 "V4" (EBool a) (EBool b) (EBool c) (EBool d) -> IR.VV4B $ IR.V4 a b c d+ x -> error $ "compValue " ++ ppShow x++compRC x = case x of+ A3 "PointCtx" a (EFloat b) c -> IR.PointCtx (compPS a) (realToFrac b) (compPSCO c)+ A2 "LineCtx" (EFloat a) b -> IR.LineCtx (realToFrac a) (compPV b)+ A4 "TriangleCtx" a b c d -> IR.TriangleCtx (compCM a) (compPM b) (compPO c) (compPV d)+ x -> error $ "compRC " ++ ppShow x++compRC' x = case x of+ A3 "PointCtx" a _ _ -> compPS' a+ A4 "TriangleCtx" _ b _ _ -> compPM' b+ x -> Nothing++compPSCO x = case x of+ A0 "LowerLeft" -> IR.LowerLeft+ A0 "UpperLeft" -> IR.UpperLeft+ x -> error $ "compPSCO " ++ ppShow x++compCM x = case x of+ A0 "CullNone" -> IR.CullNone+ A0 "CullFront" -> IR.CullFront IR.CCW+ A0 "CullBack" -> IR.CullBack IR.CCW+ x -> error $ "compCM " ++ ppShow x++compPM x = case x of+ A0 "PolygonFill" -> IR.PolygonFill+ A1 "PolygonLine" (EFloat a) -> IR.PolygonLine $ realToFrac a+ A1 "PolygonPoint" a -> IR.PolygonPoint $ compPS a+ x -> error $ "compPM " ++ ppShow x++compPM' x = case x of+ A1 "PolygonPoint" a -> compPS' a+ x -> Nothing++compPS x = case x of+ A1 "PointSize" (EFloat a) -> IR.PointSize $ realToFrac a+ A1 "ProgramPointSize" _ -> IR.ProgramPointSize+ x -> error $ "compPS " ++ ppShow x++compPS' x = case x of+ A1 "ProgramPointSize" x -> Just x+ x -> Nothing++compPO x = case x of+ A2 "Offset" (EFloat a) (EFloat b) -> IR.Offset (realToFrac a) (realToFrac b)+ A0 "NoOffset" -> IR.NoOffset+ x -> error $ "compPO " ++ ppShow x++compPV x = case x of+ A0 "FirstVertex" -> IR.FirstVertex+ A0 "LastVertex" -> IR.LastVertex+ x -> error $ "compPV " ++ ppShow x++--------------------------------------------------------------- GLSL generation++genGLSLs backend+ rp -- program point size+ (ETuple ints) -- interpolations+ (vert, tvert) -- vertex shader+ (frag, tfrag) -- fragment shader+ ffilter -- fragment filter+ = ( -- vertex input+ vertInNames++ , -- uniforms+ vertUniforms <> fragUniforms++ , -- vertex shader code+ shader $+ uniformDecls vertUniforms+ <> [shaderDecl (caseWO "attribute" "in") (text t) (text n) | (n, t) <- zip vertInNames vertIns]+ <> vertOutDecls "out"+ <> vertFuncs+ <> [mainFunc $+ vertVals+ <> [shaderLet (text n) x | (n, x) <- zip vertOutNamesWithPosition vertGLSL]+ <> [shaderLet "gl_PointSize" x | Just x <- [ptGLSL]]+ ]++ , -- fragment shader code+ shader $+ uniformDecls fragUniforms+ <> vertOutDecls "in"+ <> [shaderDecl "out" (text t) (text n) | (n, t) <- zip fragOutNames fragOuts, backend == OpenGL33]+ <> fragFuncs+ <> [mainFunc $+ fragVals+ <> [shaderStmt $ "if" <+> parens ("!" <> parens filt) <+> "discard" | Just filt <- [filtGLSL]]+ <> [shaderLet (text n) x | (n, x) <- zip fragOutNames fragGLSL ]+ ]+ )+ where+ uniformDecls us = [shaderDecl "uniform" (text $ showGLSLType "2" t) (text n) | (n, (_, t)) <- Map.toList us]+ vertOutDecls io = [shaderDecl (caseWO "varying" $ text i <+> io) (text t) (text n) | (n, (i, t)) <- zip vertOutNames vertOuts]++ fragOutNames = case length frags of+ 0 -> []+ 1 -> [caseWO "gl_FragColor" "f0"]++ (vertIns, verts) = case vert of+ Just (etaReds -> Just (xs, ETuple ys)) -> (toGLSLType "3" <$> xs, ys)+ Nothing -> ([toGLSLType "4" tvert], [mkTVar 0 tvert])++ (fragOuts, frags) = case frag of+ Just (etaReds -> Just (xs, ETuple ys)) -> (toGLSLType "31" . tyOf <$> ys, ys)+ Nothing -> ([toGLSLType "41" tfrag], [mkTVar 0 tfrag])++ (((vertGLSL, ptGLSL), (vertUniforms, (vertFuncs, vertVals))), ((filtGLSL, fragGLSL), (fragUniforms, (fragFuncs, fragVals)))) = flip evalState shaderNames $ do+ ((g1, (us1, verts)), (g2, (us2, frags))) <- (,)+ <$> runWriterT ((,)+ <$> traverse (genGLSL' "1" vertInNames . (,) vertIns) verts+ <*> traverse (genGLSL' "2" vertOutNamesWithPosition . reds) rp)+ <*> runWriterT ((,)+ <$> traverse (genGLSL' "3" vertOutNames . red) ffilter+ <*> traverse (genGLSL' "4" vertOutNames . (,) (snd <$> vertOuts)) frags)+ (,) <$> ((,) g1 <$> fixFuncs us1 mempty mempty verts) <*> ((,) g2 <$> fixFuncs us2 mempty mempty frags)++ fixFuncs :: Uniforms -> Set.Set SName -> ([Doc], [Doc]) -> Map.Map SName (ExpTV, ExpTV, [ExpTV]) -> State [SName] (Uniforms, ([Doc], [Doc]))+ fixFuncs us ns fsb (Map.toList -> fsa)+ | null fsa = return (us, fsb)+ | otherwise = do+ (unzip -> (defs, unzip -> (us', fs'))) <- forM fsa $ \(fn, (def, ty, tys)) ->+ runWriterT $ genGLSL (reverse $ take (length tys) funArgs) $ removeLams (length tys) def+ let fsb' = mconcat (zipWith combine fsa defs) <> fsb+ ns' = ns <> Set.fromList (map fst fsa)+ fixFuncs (us <> mconcat us') ns' fsb' (mconcat fs' `Map.difference` Map.fromSet (const undefined) ns')+ where+ combine (fn, (_, ty, tys)) def = case tys of+ [] -> ( [shaderDecl' ot n], [shaderLet n def] )+ _ ->+ ( [shaderFunc ot n+ (zipWith (<+>) (map (toGLSLType "45") tys) (map text funArgs))+ [shaderReturn def]]+ , []+ )+ where+ ot = toGLSLType "44" ty+ n = text fn+++ funArgs = map (("z" ++) . show) [0..]+ shaderNames = map (("s" ++) . show) [0..]+ vertInNames = map (("vi" ++) . show) [1..length vertIns]+ vertOutNames = map (("vo" ++) . show) [1..length vertOuts]+ vertOutNamesWithPosition = "gl_Position": vertOutNames++ red (etaReds -> Just (ps, o)) = (ps, o)+ red x = error $ "red: " ++ ppShow x+ reds (etaReds -> Just (ps, o)) = (ps, o)+ reds x = error $ "red: " ++ ppShow x+ genGLSL' err vertOuts (ps, o)+ | length ps == length vertOuts = genGLSL (reverse vertOuts) o+ | otherwise = error $ "makeSubst illegal input " ++ err ++ " " ++ show ps ++ "\n" ++ show vertOuts++ noUnit TTuple0 = False+ noUnit _ = True++ vertOuts = zipWith go ints $ tail verts+ where+ go (A0 n) e = (interpName n, toGLSLType "3" $ tyOf e)++ interpName "Smooth" = "smooth"+ interpName "Flat" = "flat"+ interpName "NoPerspective" = "noperspective"++ shader xs = vcat $+ ["#version" <+> caseWO "100" "330 core"]+ <> ["precision highp float;" | backend == WebGL1]+ <> ["precision highp int;" | backend == WebGL1]+ <> [shaderFunc "vec4" "texture2D" ["sampler2D s", "vec2 uv"] [shaderReturn "texture(s,uv)"] | backend == OpenGL33]+ <> [shaderFunc "mat4" "transpose" ["mat4 m"] -- todo: not just for 4 dimension+ [ shaderLet "vec4 i0" "m[0]"+ , shaderLet "vec4 i1" "m[1]"+ , shaderLet "vec4 i2" "m[2]"+ , shaderLet "vec4 i3" "m[3]"+ , shaderReturn "mat4(\+ \vec4(i0.x, i1.x, i2.x, i3.x),\+ \vec4(i0.y, i1.y, i2.y, i3.y),\+ \vec4(i0.z, i1.z, i2.z, i3.z),\+ \vec4(i0.w, i1.w, i2.w, i3.w)\+ \)"+ ]+ | backend == WebGL1 ]+ <> xs++ shaderFunc outtype name pars body = nest 4 (outtype <+> name <> tupled pars <+> "{" <$$> vcat body) <$$> "}"+ mainFunc xs = shaderFunc "void" "main" [] xs+ shaderStmt xs = nest 4 $ xs <> ";"+ shaderReturn xs = shaderStmt $ "return" <+> xs+ shaderLet a b = shaderStmt $ a <+> "=" </> b+ shaderDecl a b c = shaderDecl' (a <+> b) c+ shaderDecl' b c = shaderStmt $ b <+> c++ caseWO w o = case backend of WebGL1 -> w; OpenGL33 -> o++data Uniform+ = UUniform+ | UTexture2DSlot+ | UTexture2D Integer Integer ExpTV+ deriving (Show)++type Uniforms = Map String (Uniform, IR.InputType)++tellUniform x = tell (x, mempty)++simpleExpr = \case+ Con cn xs -> case cn of+ "Uniform" -> True+ _ -> False+ _ -> False++genGLSL :: [SName] -> ExpTV -> WriterT (Uniforms, Map.Map SName (ExpTV, ExpTV, [ExpTV])) (State [String]) Doc+genGLSL dns e = case e of++ ELit a -> pure $ text $ show a+ Var i _ -> pure $ text $ dns !! i++ Func fn def ty xs | not (simpleExpr def) -> tell (mempty, Map.singleton fn (def, ty, map tyOf xs)) >> call fn xs++ Con cn xs -> case cn of+ "primIfThenElse" -> case xs of [a, b, c] -> hsep <$> sequence [gen a, pure "?", gen b, pure ":", gen c]++ "swizzscalar" -> case xs of [e, getSwizzChar -> Just s] -> showSwizzProj [s] <$> gen e+ "swizzvector" -> case xs of [e, Con ((`elem` ["V2","V3","V4"]) -> True) (traverse getSwizzChar -> Just s)] -> showSwizzProj s <$> gen e++ "Uniform" -> case xs of+ [EString s] -> do+ tellUniform $ Map.singleton s $ (,) UUniform $ compInputType "unif" $ tyOf e+ pure $ text s+ "Sampler" -> case xs of+ [_, _, A1 "Texture2DSlot" (EString s)] -> do+ tellUniform $ Map.singleton s $ (,) UTexture2DSlot IR.FTexture2D{-compInputType $ tyOf e -- TODO-}+ pure $ text s+ [_, _, A2 "Texture2D" (A2 "V2" (EInt w) (EInt h)) b] -> do+ s <- newName+ tellUniform $ Map.singleton s $ (,) (UTexture2D w h b) IR.FTexture2D+ pure $ text s++ 'P':'r':'i':'m':n | n'@(_:_) <- trName (dropS n) -> call n' xs+ where+ ifType p a b = if all (p . tyOf) xs then a else b++ dropS n+ | last n == 'S' && init n `elem` ["Add", "Sub", "Div", "Mod", "BAnd", "BOr", "BXor", "BShiftL", "BShiftR", "Min", "Max", "Clamp", "Mix", "Step", "SmoothStep"] = init n+ | otherwise = n++ trName = \case++ -- Arithmetic Functions+ "Add" -> "+"+ "Sub" -> "-"+ "Neg" -> "-_"+ "Mul" -> ifType isMatrix "matrixCompMult" "*"+ "MulS" -> "*"+ "Div" -> "/"+ "Mod" -> ifType isIntegral "%" "mod"++ -- Bit-wise Functions+ "BAnd" -> "&"+ "BOr" -> "|"+ "BXor" -> "^"+ "BNot" -> "~_"+ "BShiftL" -> "<<"+ "BShiftR" -> ">>"++ -- Logic Functions+ "And" -> "&&"+ "Or" -> "||"+ "Xor" -> "^"+ "Not" -> ifType isScalar "!_" "not"++ -- Integer/Float Conversion Functions+ "FloatBitsToInt" -> "floatBitsToInt"+ "FloatBitsToUInt" -> "floatBitsToUint"+ "IntBitsToFloat" -> "intBitsToFloat"+ "UIntBitsToFloat" -> "uintBitsToFloat"++ -- Matrix Functions+ "OuterProduct" -> "outerProduct"+ "MulMatVec" -> "*"+ "MulVecMat" -> "*"+ "MulMatMat" -> "*"++ -- Fragment Processing Functions+ "DFdx" -> "dFdx"+ "DFdy" -> "dFdy"++ -- Vector and Scalar Relational Functions+ "LessThan" -> ifType isScalarNum "<" "lessThan"+ "LessThanEqual" -> ifType isScalarNum "<=" "lessThanEqual"+ "GreaterThan" -> ifType isScalarNum ">" "greaterThan"+ "GreaterThanEqual" -> ifType isScalarNum ">=" "greaterThanEqual"+ "Equal" -> "=="+ "EqualV" -> ifType isScalar "==" "equal"+ "NotEqual" -> "!="+ "NotEqualV" -> ifType isScalar "!=" "notEqual"++ -- Angle and Trigonometry Functions+ "ATan2" -> "atan"+ -- Exponential Functions+ "InvSqrt" -> "inversesqrt"+ -- Common Functions+ "RoundEven" -> "roundEven"+ "ModF" -> error "PrimModF is not implemented yet!" -- TODO+ "MixB" -> "mix"++ n | n `elem`+ -- Logic Functions+ [ "Any", "All"+ -- Angle and Trigonometry Functions+ , "ACos", "ACosH", "ASin", "ASinH", "ATan", "ATanH", "Cos", "CosH", "Degrees", "Radians", "Sin", "SinH", "Tan", "TanH"+ -- Exponential Functions+ , "Pow", "Exp", "Exp2", "Log2", "Sqrt"+ -- Common Functions+ , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Step", "SmoothStep"+ -- Geometric Functions+ , "Length", "Distance", "Dot", "Cross", "Normalize", "FaceForward", "Reflect", "Refract"+ -- Matrix Functions+ , "Transpose", "Determinant", "Inverse"+ -- Fragment Processing Functions+ , "FWidth"+ -- Noise Functions+ , "Noise1", "Noise2", "Noise3", "Noise4"+ ] -> map toLower n++ _ -> ""++ n | n@(_:_) <- trName n -> call n xs+ where+ trName n = case n of+ "texture2D" -> "texture2D"++ "True" -> "true"+ "False" -> "false"++ "M22F" -> "mat2"+ "M33F" -> "mat3"+ "M44F" -> "mat4"++ "==" -> "=="++ n | n `elem` ["primNegateWord", "primNegateInt", "primNegateFloat"] -> "-_"+ n | n `elem` ["V2", "V3", "V4"] -> toGLSLType (n ++ " " ++ show (length xs)) $ tyOf e+ _ -> ""++ -- not supported+ n | n `elem` ["primIntToWord", "primIntToFloat", "primCompareInt", "primCompareWord", "primCompareFloat"] -> error $ "WebGL 1 does not support: " ++ ppShow e+ n | n `elem` ["M23F", "M24F", "M32F", "M34F", "M42F", "M43F"] -> error "WebGL 1 does not support matrices with this dimension"+ x -> error $ "GLSL codegen - unsupported function: " ++ ppShow x++ x -> error $ "GLSL codegen - unsupported expression: " ++ ppShow x+ where+ newName = gets head <* modify tail++ call f xs = case f of+ (c:_) | isAlpha c -> case xs of+ [] -> return $ text f+ xs -> (text f </>) . tupled <$> mapM gen xs+ [op, '_'] -> case xs of [a] -> (text [op] <+>) . parens <$> gen a+ o -> case xs of [a, b] -> hsep <$> sequence [parens <$> gen a, pure $ text o, parens <$> gen b]++ gen = genGLSL dns++ isMatrix :: Ty -> Bool+ isMatrix TMat{} = True+ isMatrix _ = False++ isIntegral :: Ty -> Bool+ isIntegral TWord = True+ isIntegral TInt = True+ isIntegral (TVec _ TWord) = True+ isIntegral (TVec _ TInt) = True+ isIntegral _ = False++ isScalarNum :: Ty -> Bool+ isScalarNum = \case+ TInt -> True+ TWord -> True+ TFloat -> True+ _ -> False++ isScalar :: Ty -> Bool+ isScalar TBool = True+ isScalar x = isScalarNum x++ getSwizzChar = \case+ A0 "Sx" -> Just 'x'+ A0 "Sy" -> Just 'y'+ A0 "Sz" -> Just 'z'+ A0 "Sw" -> Just 'w'+ _ -> Nothing++ showSwizzProj x a = parens a <> "." <> text x++--------------------------------------------------------------------------------++-- expression + type + type of local variables+data ExpTV = ExpTV_ Exp Exp [Exp]+ deriving (Show, Eq)++pattern ExpTV a b c <- ExpTV_ a b c where ExpTV a b c = ExpTV_ (a) (unLab' b) c++type Ty = ExpTV++tyOf :: ExpTV -> Ty+tyOf (ExpTV _ t vs) = t .@ vs++expOf (ExpTV x _ _) = x++mapVal f (ExpTV a b c) = ExpTV (f a) b c++toExp :: ExpType -> ExpTV+toExp (x, xt) = ExpTV x xt []++pattern Pi h a b <- (mkPi . mapVal unLab' -> Just (h, a, b))+pattern Lam h a b <- (mkLam . mapVal unFunc' -> Just (h, a, b))+pattern Con h b <- (mkCon . mapVal unLab' -> Just (h, b))+pattern App a b <- (mkApp . mapVal unLab' -> Just (a, b))+pattern Var a b <- (mkVar . mapVal unLab' -> Just (a, b))+pattern ELit l <- ExpTV (I.ELit l) _ _+pattern TType <- ExpTV (unLab' -> I.TType) _ _+pattern Func fn def ty xs <- (mkFunc -> Just (fn, def, ty, xs))++pattern EString s <- ELit (LString s)+pattern EFloat s <- ELit (LFloat s)+pattern EInt s <- ELit (LInt s)++t .@ vs = ExpTV t I.TType vs+infix 1 .@++mkVar (ExpTV (I.Var i) t vs) = Just (i, t .@ vs)+mkVar _ = Nothing++mkPi (ExpTV (I.Pi b x y) _ vs) = Just (b, x .@ vs, y .@ addToEnv x vs)+mkPi _ = Nothing++mkLam (ExpTV (I.Lam y) (I.Pi b x yt) vs) = Just (b, x .@ vs, ExpTV y yt $ addToEnv x vs)+mkLam _ = Nothing++mkCon (ExpTV (I.Con s n xs) et vs) = Just (untick $ show s, chain vs (conType et s) $ mkConPars n et ++ xs)+mkCon (ExpTV (TyCon s xs) et vs) = Just (untick $ show s, chain vs (nType s) xs)+mkCon (ExpTV (Neut (I.Fun s i (reverse -> xs) def)) et vs) = Just (untick $ show s, chain vs (nType s) xs)+mkCon (ExpTV (CaseFun s xs n) et vs) = Just (untick $ show s, chain vs (nType s) $ makeCaseFunPars' (mkEnv vs) n ++ xs ++ [Neut n])+mkCon (ExpTV (TyCaseFun s [m, t, f] n) et vs) = Just (untick $ show s, chain vs (nType s) [m, t, Neut n, f])+mkCon _ = Nothing++mkApp (ExpTV (Neut (I.App_ a b)) et vs) = Just (ExpTV (Neut a) t vs, head $ chain vs t [b])+ where t = neutType' (mkEnv vs) a+mkApp _ = Nothing++mkFunc r@(ExpTV (I.Func (show -> n) def nt xs) ty vs) | all (supType . tyOf) (r: xs') && n `notElem` ["typeAnn"] && all validChar n+ = Just (untick n +++ intercalate "_" (filter (/="TT") $ map (filter isAlphaNum . removeEscs . ppShow) hs), toExp (foldl app_ def hs, foldl appTy nt hs), tyOf r, xs')+ where+ a +++ [] = a+ a +++ b = a ++ "_" ++ b+ (map (expOf . snd) -> hs, map snd -> xs') = span ((==Hidden) . fst) $ chain' vs nt $ reverse xs+ validChar = isAlphaNum+mkFunc _ = Nothing++chain vs t@(I.Pi Hidden at y) (a: as) = chain vs (appTy t a) as+chain vs t xs = map snd $ chain' vs t xs++chain' vs t [] = []+chain' vs t@(I.Pi b at y) (a: as) = (b, ExpTV a at vs): chain' vs (appTy t a) as+chain' vs t _ = error $ "chain: " ++ show t++mkTVar i (ExpTV t _ vs) = ExpTV (I.Var i) t vs++unLab' (FL x) = unLab' x+unLab' (LabelEnd x) = unLab' x+unLab' x = x++unFunc' (FL x) = unFunc' x -- todo: remove?+unFunc' (UFL x) = unFunc' x+unFunc' (LabelEnd x) = unFunc' x+unFunc' x = x++instance Subst Exp ExpTV where+ subst_ i0 dx x (ExpTV a at vs) = ExpTV (subst_ i0 dx x a) (subst_ i0 dx x at) (zipWith (\i -> subst_ (i0+i) (upDB i dx) $ up i x{-todo: review-}) [1..] vs)++addToEnv x xs = x: xs+mkEnv xs = {-trace_ ("mk " ++ show (length xs)) $ -} zipWith up [1..] xs++instance Up ExpTV where+ up_ n i (ExpTV x xt vs) = error "up @ExpTV" --ExpTV (up_ n i x) (up_ n i xt) (up_ n i <$> vs)+ used i (ExpTV x xt vs) = used i x || used i xt -- -|| any (used i) vs{-?-}+ fold = error "fold @ExpTV"+ maxDB_ (ExpTV a b cs) = maxDB_ a <> maxDB_ b -- <> foldMap maxDB_ cs{-?-}+ closedExp (ExpTV a b cs) = ExpTV (closedExp a) (closedExp b) cs++instance PShow ExpTV where+ pShowPrec p (ExpTV x t _) = pShowPrec p (x, t)++isSampler (TyCon n _) = show n == "'Sampler"+isSampler _ = False++untick ('\'': s) = s+untick s = s++-------------------------------------------------------------------------------- ExpTV conversion -- TODO: remove++removeLams 0 x = x+removeLams i (ELam _ x) = removeLams (i-1) x+removeLams i (Lam Hidden _ x) = removeLams i x++etaReds (ELam _ (App (down 0 -> Just f) (EVar 0))) = etaReds f+etaReds (ELam _ (hlistLam -> x@Just{})) = x+etaReds (ELam p i) = Just ([p], i)+etaReds x = Nothing++hlistLam :: ExpTV -> Maybe ([ExpTV], ExpTV)+hlistLam (A3 "hlistNilCase" _ (down 0 -> Just x) (EVar 0)) = Just ([], x)+hlistLam (A3 "hlistConsCase" _ (down 0 -> Just (getPats 2 -> Just ([p, px], x))) (EVar 0)) = first (p:) <$> hlistLam x+hlistLam _ = Nothing++getPats 0 e = Just ([], e)+getPats i (ELam p e) = first (p:) <$> getPats (i-1) e+getPats i (Lam Hidden p (down 0 -> Just e)) = getPats i e+getPats i x = error $ "getPats: " ++ show i ++ " " ++ ppShow x++pattern EtaPrim1 s <- (getEtaPrim -> Just (s, []))+pattern EtaPrim2 s x <- (getEtaPrim -> Just (s, [x]))+pattern EtaPrim3 s x1 x2 <- (getEtaPrim -> Just (s, [x1, x2]))+pattern EtaPrim4 s x1 x2 x3 <- (getEtaPrim -> Just (s, [x1, x2, x3]))+pattern EtaPrim5 s x1 x2 x3 x4 <- (getEtaPrim -> Just (s, [x1, x2, x3, x4]))+pattern EtaPrim2_2 s <- (getEtaPrim2 -> Just (s, []))++getEtaPrim (ELam _ (Con s (initLast -> Just (traverse (down 0) -> Just xs, EVar 0)))) = Just (s, xs)+getEtaPrim _ = Nothing++getEtaPrim2 (ELam _ (ELam _ (Con s (initLast -> Just (initLast -> Just (traverse (down 0) -> Just (traverse (down 0) -> Just xs), EVar 0), EVar 0))))) = Just (s, xs)+getEtaPrim2 _ = Nothing++initLast [] = Nothing+initLast xs = Just (init xs, last xs)++-------------++pattern EVar n <- Var n _+pattern ELam t b <- Lam Visible t b++pattern A0 n <- Con n []+pattern A1 n a <- Con n [a]+pattern A2 n a b <- Con n [a, b]+pattern A3 n a b c <- Con n [a, b, c]+pattern A4 n a b c d <- Con n [a, b, c, d]+pattern A5 n a b c d e <- Con n [a, b, c, d, e]++pattern TTuple0 <- A1 "HList" (A0 "Nil")+pattern TBool <- A0 "Bool"+pattern TWord <- A0 "Word"+pattern TInt <- A0 "Int"+pattern TNat <- A0 "Nat"+pattern TFloat <- A0 "Float"+pattern TString <- A0 "String"+pattern TVec n a <- A2 "VecS" a (Nat n)+pattern TMat i j a <- A3 "Mat" (Nat i) (Nat j) a++pattern Nat n <- (fromNat -> Just n)++fromNat :: ExpTV -> Maybe Int+fromNat (A0 "Zero") = Just 0+fromNat (A1 "Succ" n) = (1 +) <$> fromNat n+fromNat _ = Nothing++pattern TTuple xs <- (getTTuple -> Just xs)+pattern ETuple xs <- (getTuple -> Just xs)++getTTuple (A1 "HList" l) = Just $ compList l+getTTuple _ = Nothing++getTuple (A0 "HNil") = Just []+getTuple (A2 "HCons" x (getTuple -> Just xs)) = Just (x: xs)+getTuple _ = Nothing
src/LambdaCube/Compiler/Infer.hs view
@@ -15,1444 +15,1509 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove -- {-# OPTIONS_GHC -O0 #-} module LambdaCube.Compiler.Infer- ( Binder (..), SName, Lit(..), Visibility(..), Export(..), Module(..)- , Exp (..), ExpType, GlobalEnv- , pattern Var, pattern Fun, pattern CaseFun, pattern TyCaseFun, pattern App_, pattern PMLabel, pattern FixLabel- , pattern Con, pattern TyCon, pattern Pi, pattern Lam- , outputType, boolType, trueExp- , down- , litType- , initEnv, Env(..), pattern EBind2- , Infos(..), listInfos, ErrorMsg(..), PolyEnv(..), ErrorT, throwErrorTCM, parseLC, joinPolyEnvs, filterPolyEnv, inference_- , ImportItems (..)- , SI(..), Range(..)- , nType, neutType, appTy, mkConPars, makeCaseFunPars, unpmlabel- , MaxDB(..)- ) where-import Data.Monoid-import Data.Maybe-import qualified Data.Set as Set-import qualified Data.Map as Map--import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Writer-import Control.Monad.State-import Control.Monad.Identity-import Control.Arrow hiding ((<+>))-import Control.DeepSeq--import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)-import LambdaCube.Compiler.Lexer-import LambdaCube.Compiler.Parser---------------------------------------------------------------------------------- core expression representation--data Exp- = TType- | ELit Lit- | Con_ MaxDB ConName !Int [Exp]- | TyCon_ MaxDB TyConName [Exp]- | Pi_ MaxDB Visibility Exp Exp- | Lam_ MaxDB Exp- | Neut Neutral- | Label LabelKind Exp{-folded expression-} Exp{-unfolded expression-}- | LabelEnd_ LEKind Exp- deriving (Show)--data Neutral- = Fun__ MaxDB FunName [Exp]- | CaseFun__ MaxDB CaseFunName [Exp] Neutral- | TyCaseFun__ MaxDB TyCaseFunName [Exp] Neutral- | App__ MaxDB Neutral Exp- | Var_ !Int -- De Bruijn variable- | PMLabel_ FunName !Int [Exp] Exp{-unfolded expression-}- deriving (Show)--data ConName = ConName SName MFixity Int{-ordinal number, e.g. Zero:0, Succ:1-} TyConName Type--data TyConName = TyConName SName MFixity Int{-num of indices-} Type [ConName]{-constructors-} CaseFunName--data FunName = FunName_ SName ([Exp] -> Exp) MFixity Type-pattern FunName a b c <- FunName_ a _ b c where FunName a b c = funName a b c--funName a b c = n where n = FunName_ a (getFunDef n) b c--data CaseFunName = CaseFunName SName Type Int{-num of parameters-}--data TyCaseFunName = TyCaseFunName SName Type--type Type = Exp-type ExpType = (Exp, Type)-type SExp2 = SExp' ExpType--instance Show ConName where show (ConName n _ _ _ _) = n-instance Eq ConName where ConName _ _ n _ _ == ConName _ _ n' _ _ = n == n'-instance Show TyConName where show (TyConName n _ _ _ _ _) = n-instance Eq TyConName where TyConName n _ _ _ _ _ == TyConName n' _ _ _ _ _ = n == n'-instance Show FunName where show (FunName n _ _) = n-instance Eq FunName where FunName n _ _ == FunName n' _ _ = n == n'-instance Show CaseFunName where show (CaseFunName n _ _) = caseName n-instance Eq CaseFunName where CaseFunName n _ _ == CaseFunName n' _ _ = n == n'-instance Show TyCaseFunName where show (TyCaseFunName n _) = MatchName n-instance Eq TyCaseFunName where TyCaseFunName n _ == TyCaseFunName n' _ = n == n'---------------------------------------------------------------------------------- auxiliary functions and patterns--infixl 2 `App`, `app_`-infixr 1 :~>--pattern Fun_ a b <- Fun__ _ a b where Fun_ a b = Fun__ (foldMap maxDB_ b) a b-pattern CaseFun_ a b c <- CaseFun__ _ a b c where CaseFun_ a b c = CaseFun__ (foldMap maxDB_ b <> maxDB_ c) a b c-pattern TyCaseFun_ a b c <- TyCaseFun__ _ a b c where TyCaseFun_ a b c = TyCaseFun__ (foldMap maxDB_ b <> maxDB_ c) a b c-pattern App_ a b <- App__ _ a b where App_ a b = App__ (maxDB_ a <> maxDB_ b) a b-pattern Fun a b = Neut (Fun_ a b)-pattern CaseFun a b c = Neut (CaseFun_ a b c)-pattern TyCaseFun a b c = Neut (TyCaseFun_ a b c)-pattern App a b <- Neut (App_ (Neut -> a) b)-pattern Var a = Neut (Var_ a)--conParams (conTypeName -> TyConName _ _ _ _ _ (CaseFunName _ _ pars)) = pars-mkConPars n (snd . getParams -> TyCon (TyConName _ _ _ _ _ (CaseFunName _ _ pars)) xs) = take (min n pars) xs-mkConPars n x = error $ "mkConPars: " ++ ppShow x-conName a b c d = ConName a b c (get $ snd $ getParams d) d- where- get (TyCon s _) = s--makeCaseFunPars te n = case neutType te n of- TyCon (TyConName _ _ _ _ _ (CaseFunName _ _ pars)) xs -> take pars xs--pattern Closed :: () => Up a => a -> a-pattern Closed a <- a where Closed a = closedExp a--pattern Con x n y <- Con_ _ x n y where Con x n y = Con_ (foldMap maxDB_ y) x n y-pattern ConN s a <- Con (ConName s _ _ _ _) _ a-tCon s i t a = Con (conName s Nothing i t) 0 a-pattern TyCon x y <- TyCon_ _ x y where TyCon x y = TyCon_ (foldMap maxDB_ y) x y-pattern Lam y <- Lam_ _ y where Lam y = Lam_ (lowerDB (maxDB_ y)) y-pattern Pi v x y <- Pi_ _ v x y where Pi v x y = Pi_ (maxDB_ x <> lowerDB (maxDB_ y)) v x y-pattern FunN a b <- Fun (FunName a _ _) b-pattern TFun a t b <- Fun (FunName a _ t) b where TFun a t b = Fun (FunName a Nothing t) b-pattern TFun' a t b <- Fun_ (FunName a _ t) b where TFun' a t b = Fun_ (FunName a Nothing t) b-pattern TyConN s a <- TyCon (TyConName s _ _ _ _ _) a-pattern TTyCon s t a <- TyCon (TyConName s _ _ t _ _) a where TTyCon s t a = TyCon (TyConName s Nothing (error "todo: inum") t (error "todo: tcn cons 2") $ CaseFunName (error "TTyCon-A") (error "TTyCon-B") $ length a) a-pattern TTyCon0 s <- TyCon (TyConName s _ _ TType _ _) [] where TTyCon0 s = Closed $ TyCon (TyConName s Nothing 0 TType (error "todo: tcn cons 3") $ CaseFunName (error "TTyCon0-A") (error "TTyCon0-B") 0) []-pattern a :~> b = Pi Visible a b--pattern Unit = TTyCon0 "'Unit"-pattern TInt = TTyCon0 "'Int"-pattern TNat = TTyCon0 "'Nat"-pattern TBool = TTyCon0 "'Bool"-pattern TFloat = TTyCon0 "'Float"-pattern TString = TTyCon0 "'String"-pattern TChar = TTyCon0 "'Char"-pattern TOrdering = TTyCon0 "'Ordering"-pattern TTuple2 a b = TTyCon "'Tuple2" (TType :~> TType :~> TType) [a, b]-pattern TVec a b = TTyCon "'VecS" (TType :~> TNat :~> TType) [b, a]-pattern Empty s <- TyCon (TyConName "'Empty" _ _ _ _ _) [EString s] where- Empty s = TyCon (TyConName "'Empty" Nothing (error "todo: inum2_") (TString :~> TType) (error "todo: tcn cons 3_") $ error "Empty") [EString s]--pattern TT <- ConN "TT" _ where TT = Closed (tCon "TT" 0 Unit [])-pattern Zero <- ConN "Zero" _ where Zero = Closed (tCon "Zero" 0 TNat [])-pattern Succ n <- ConN "Succ" (n:_) where Succ n = tCon "Succ" 1 (TNat :~> TNat) [n]--pattern CstrT t a b = TFun "'EqCT" (TType :~> Var 0 :~> Var 1 :~> TType) [t, a, b]-pattern CstrT' t a b = TFun' "'EqCT" (TType :~> Var 0 :~> Var 1 :~> TType) [t, a, b]-pattern ReflCstr x = TFun "reflCstr" (TType :~> CstrT TType (Var 0) (Var 0)) [x]-pattern Coe a b w x = TFun "coe" (TType :~> TType :~> CstrT TType (Var 1) (Var 0) :~> Var 2 :~> Var 2) [a,b,w,x]-pattern ParEval t a b = TFun "parEval" (TType :~> Var 0 :~> Var 1 :~> Var 2) [t, a, b]-pattern Undef t = TFun "undefined" (Pi Hidden TType (Var 0)) [t]-pattern T2 a b = TFun "'T2" (TType :~> TType :~> TType) [a, b]-pattern T2C a b = TFun "t2C" (Unit :~> Unit :~> Unit) [a, b]-pattern CSplit a b c <- FunN "'Split" [a, b, c]--pattern EInt a = ELit (LInt a)-pattern EFloat a = ELit (LFloat a)-pattern EChar a = ELit (LChar a)-pattern EString a = ELit (LString a)-pattern EBool a <- (getEBool -> Just a) where EBool = mkBool-pattern ENat n <- (fromNatE -> Just n) where ENat = toNatE--pattern LCon <- (isCon -> True)-pattern CFun <- (isCaseFun -> True)-pattern NoTup <- (noTup -> True)----pattern Sigma a b <- TyConN "Sigma" [a, Lam b] where Sigma a b = TTyCon "Sigma" (error "sigmatype") [a, Lam Visible a{-todo: don't duplicate-} b]---pattern TVec a b = TTyCon "'Vec" (TNat :~> TType :~> TType) [a, b]---pattern Tuple2 a b c d = tCon "Tuple2" 0 Tuple2Type [a, b, c, d]---pattern Tuple0 = tCon "Tuple0" 0 TTuple0 []---pattern TTuple0 :: Exp---pattern TTuple0 <- _ where TTuple0 = TTyCon0 "'Tuple0"---pattern Tuple2Type :: Exp---pattern Tuple2Type <- _ where Tuple2Type = Pi Hidden TType $ Pi Hidden TType $ Var 1 :~> Var 1 :~> TTuple2 (Var 3) (Var 2)---tTuple3 a b c = TTyCon "'Tuple3" (TType :~> TType :~> TType :~> TType) [a, b, c]--toNatE :: Int -> Exp-toNatE 0 = Closed Zero-toNatE n | n > 0 = Closed (Succ (toNatE (n - 1)))--fromNatE :: Exp -> Maybe Int-fromNatE Zero = Just 0-fromNatE (Succ n) = (1 +) <$> fromNatE n-fromNatE _ = Nothing--mkBool False = Closed $ tCon "False" 0 TBool []-mkBool True = Closed $ tCon "True" 1 TBool []--getEBool (ConN "False" _) = Just False-getEBool (ConN "True" _) = Just True-getEBool _ = Nothing--isCaseFun Fun{} = True-isCaseFun CaseFun{} = True-isCaseFun TyCaseFun{} = True-isCaseFun _ = False--isCon = \case- TType{} -> True- Con{} -> True- TyCon{} -> True- ELit{} -> True- _ -> False--mkOrdering x = Closed $ case x of- LT -> tCon "LT" 0 TOrdering []- EQ -> tCon "EQ" 1 TOrdering []- GT -> tCon "GT" 2 TOrdering []--noTup (TyConN s _) = take 6 s /= "'Tuple" -- todo-noTup _ = False--conTypeName :: ConName -> TyConName-conTypeName (ConName _ _ _ t _) = t--outputType = TTyCon0 "'Output"-boolType = TBool-trueExp = EBool True---------------------------------------------------------------------------------- label handling--data LabelKind- = {-LabelPM -- pattern match label- | -}LabelFix -- fix unfold label- deriving (Show)--pattern PMLabel f i x y = Neut (PMLabel_ f i x y)-pattern FixLabel x y = Label LabelFix x y--data LEKind- = LEPM- | LEClosed- deriving (Show, Eq)--pattern LabelEnd x = LabelEnd_ LEPM x---pattern ClosedExp x = LabelEnd_ LEClosed x--label LabelFix x y = FixLabel x y-pmLabel :: FunName -> Int -> [Exp] -> Exp -> Exp-pmLabel _ _ _ (unlabel'' -> LabelEnd y) = y-pmLabel f i xs y@Neut{} = PMLabel f i xs y-pmLabel f i xs y@Lam{} = PMLabel f i xs y-pmLabel f i xs y = error $ "pmLabel: " ++ show y--pattern UL a <- (unlabel -> a) where UL = unlabel--unpmlabel (PMLabel f i a _)- | i >= 0 = iterateN i Lam $ Fun f $ a ++ downTo 0 i- | otherwise = foldl app_ (Fun f $ reverse $ drop (-i) $ reverse a) (reverse $ take (-i) $ reverse a)--unlabel x@PMLabel{} = unlabel (unpmlabel x)-unlabel (FixLabel _ a) = unlabel a---unlabel (LabelEnd_ _ a) = unlabel a-unlabel a = a--unlabel'' (FixLabel _ a) = unlabel'' a-unlabel'' a = a--pattern UL' a <- (unlabel' -> a) where UL' = unlabel'----unlabel (PMLabel a _) = unlabel a---unlabel (FixLabel _ a) = unlabel a-unlabel' (LabelEnd_ _ a) = unlabel' a-unlabel' a = a----------------------------------------------------------------------------------- low-level toolbox--class Up a => Subst b a where- subst :: Int -> b -> a -> a--down :: (Subst Exp a) => Int -> a -> Maybe a-down t x | used t x = Nothing- | otherwise = Just $ subst t (error "impossible: down" :: Exp) x--instance Eq Exp where- FixLabel a _ == FixLabel a' _ = a == a'- FixLabel _ a == a' = a == a'- a == FixLabel _ a' = a == a'- LabelEnd_ k a == a' = a == a'- a == LabelEnd_ k' a' = a == a'- Lam a == Lam a' = a == a'- Pi a b c == Pi a' b' c' = (a, b, c) == (a', b', c')- Con a n b == Con a' n' b' = (a, n, b) == (a', n', b')- TyCon a b == TyCon a' b' = (a, b) == (a', b')- TType == TType = True- ELit l == ELit l' = l == l'- Neut a == Neut a' = a == a'- _ == _ = False--instance Eq Neutral where- PMLabel_ f i a _ == PMLabel_ f' i' a' _ = (f, i, a) == (f', i', a')- Fun_ a b == Fun_ a' b' = (a, b) == (a', b')- CaseFun_ a b c == CaseFun_ a' b' c' = (a, b, c) == (a', b', c')- TyCaseFun_ a b c == TyCaseFun_ a' b' c' = (a, b, c) == (a', b', c')- App_ a b == App_ a' b' = (a, b) == (a', b')- Var_ a == Var_ a' = a == a'- _ == _ = False--isClosed (maxDB_ -> MaxDB x) = isNothing x---- 0 means that no free variable is used--- 1 means that only var 0 is used-maxDB = max 0 . fromMaybe 0 . getMaxDB . maxDB_-upDB n (MaxDB i) = MaxDB $ (\x -> if x == 0 then x else x+n) <$> i--free x | isClosed x = mempty-free x = fold (\i k -> Set.fromList [k - i | k >= i]) 0 x--instance Up Exp where- up_ 0 = \_ e -> e- up_ n = f where- f i e | isClosed e = e- f i e = case e of- Lam_ md b -> Lam_ (upDB n md) (f (i+1) b)- Pi_ md h a b -> Pi_ (upDB n md) h (f i a) (f (i+1) b)- Con_ md s pn as -> Con_ (upDB n md) s pn $ map (f i) as- TyCon_ md s as -> TyCon_ (upDB n md) s $ map (f i) as- Neut x -> Neut $ up_ n i x- Label lk x y -> Label lk (f i x) $ f i y- LabelEnd_ k x -> LabelEnd_ k $ f i x-- used i e- | i >= maxDB e = False- | otherwise = ((getAny .) . fold ((Any .) . (==))) i e-- fold f i = \case- FixLabel _ x -> fold f i x- Lam b -> {-fold f i t <> todo: explain why this is not needed -} fold f (i+1) b- Pi _ a b -> fold f i a <> fold f (i+1) b- Con _ _ as -> foldMap (fold f i) as- TyCon _ as -> foldMap (fold f i) as- TType -> mempty- ELit _ -> mempty- LabelEnd_ _ x -> fold f i x- Neut x -> fold f i x-- maxDB_ = \case- Lam_ c _ -> c- Pi_ c _ _ _ -> c- Con_ c _ _ _ -> c- TyCon_ c _ _ -> c-- Neut x -> maxDB_ x- FixLabel x y -> maxDB_ x <> maxDB_ y- TType -> mempty- ELit _ -> mempty- LabelEnd_ _ x -> maxDB_ x-- closedExp = \case- Lam_ _ c -> Lam_ mempty c- Pi_ _ a b c -> Pi_ mempty a b c- Con_ _ a b c -> Con_ mempty a b c- TyCon_ _ a b -> TyCon_ mempty a b- Neut a -> Neut $ closedExp a- Label lk a b -> Label lk (closedExp a) (closedExp b)- LabelEnd a -> LabelEnd (closedExp a)- e -> e--instance Subst Exp Exp where- subst i0 x = f i0- where- f i (Neut n) = substNeut n- where- substNeut e | isClosed e = Neut e- substNeut e = case e of- Var_ k -> case compare k i of GT -> Var $ k - 1; LT -> Var k; EQ -> up (i - i0) x- Fun_ s as -> evalFun s $ f i <$> as- CaseFun_ s as n -> evalCaseFun s (f i <$> as) (substNeut n)- TyCaseFun_ s as n -> evalTyCaseFun s (f i <$> as) (substNeut n)- App_ a b -> app_ (substNeut a) (f i b)- PMLabel_ fn c xs v -> pmLabel fn c (f i <$> xs) $ f i v- f i e | {-i >= maxDB e-} isClosed e = e- f i e = case e of- Label lk z v -> label lk (f i z) $ f i v- Lam b -> Lam (f (i+1) b)- Con s n as -> Con s n $ f i <$> as- Pi h a b -> Pi h (f i a) (f (i+1) b)- TyCon s as -> TyCon s $ f i <$> as- LabelEnd_ k a -> LabelEnd_ k $ f i a--instance Up Neutral where-- up_ 0 = \_ e -> e- up_ n = f where- f i e | isClosed e = e- f i e = case e of- Var_ k -> Var_ $ if k >= i then k+n else k- Fun__ md s as -> Fun__ (upDB n md) s $ map (up_ n i) as- CaseFun__ md s as ne -> CaseFun__ (upDB n md) s (up_ n i <$> as) (up_ n i ne)- TyCaseFun__ md s as ne -> TyCaseFun__ (upDB n md) s (up_ n i <$> as) (up_ n i ne)- App__ md a b -> App__ (upDB n md) (up_ n i a) (up_ n i b)- PMLabel_ fn c x y -> PMLabel_ fn c (up_ n i <$> x) $ up_ n i y-- used i e- | i >= maxDB e = False- | otherwise = ((getAny .) . fold ((Any .) . (==))) i e-- fold f i = \case- Var_ k -> f i k- Fun_ _ as -> foldMap (fold f i) as- CaseFun_ _ as n -> foldMap (fold f i) as <> fold f i n- TyCaseFun_ _ as n -> foldMap (fold f i) as <> fold f i n- App_ a b -> fold f i a <> fold f i b- PMLabel_ _ _ x _ -> foldMap (fold f i) x-- maxDB_ = \case- Var_ k -> varDB k- Fun__ c _ _ -> c- CaseFun__ c _ _ _ -> c- TyCaseFun__ c _ _ _ -> c- App__ c a b -> c- PMLabel_ _ _ x _ -> foldMap maxDB_ x-- closedExp = \case- x@Var_{} -> error "impossible"- Fun__ _ a as -> Fun__ mempty a as- CaseFun__ _ a as n -> CaseFun__ mempty a as n- TyCaseFun__ _ a as n -> TyCaseFun__ mempty a as n- App__ _ a b -> App__ mempty a b- PMLabel_ f i x y -> PMLabel_ f i (map closedExp x) (closedExp y)--instance (Subst x a, Subst x b) => Subst x (a, b) where- subst i x (a, b) = (subst i x a, subst i x b)--varType :: String -> Int -> Env -> (Binder, Exp)-varType err n_ env = f n_ env where- f n (EAssign i (x, _) es) = second (subst i x) $ f (if n < i then n else n+1) es- f n (EBind2 b t es) = if n == 0 then (b, up 1 t) else second (up 1) $ f (n-1) es- f n (ELet2 _ (x, t) es) = if n == 0 then (BLam Visible{-??-}, up 1 t) else second (up 1) $ f (n-1) es- f n e = either (error $ "varType: " ++ err ++ "\n" ++ show n_ ++ "\n" ++ ppShow env) (f n) $ parent e---------------------------------------------------------------------------------- reduction--evalCaseFun a ps (Con (ConName _ _ i _ _) _ vs)- | i /= (-1) = foldl app_ (ps !! (i + 1)) vs- | otherwise = error "evcf"-evalCaseFun a b (Neut c) = CaseFun a b c-evalCaseFun a b (FixLabel _ c) = evalCaseFun a b c--evalTyCaseFun a b (Neut c) = TyCaseFun a b c-evalTyCaseFun a b (FixLabel _ c) = evalTyCaseFun a b c-evalTyCaseFun (TyCaseFunName n ty) [_, t, f] (TyCon (TyConName n' _ _ _ _ _) vs) | n == n' = foldl app_ t vs-evalTyCaseFun (TyCaseFunName n ty) [_, t, f] _ = f--evalCoe a b TT d = d-evalCoe a b t d = Coe a b t d--{- todo: generate- Fun n@(FunName "natElim" _ _) [a, z, s, Succ x] -> let -- todo: replace let with better abstraction- sx = s `app_` x- in sx `app_` eval (Fun n [a, z, s, x])- MT "natElim" [_, z, s, Zero] -> z- Fun na@(FunName "finElim" _ _) [m, z, s, n, ConN "FSucc" [i, x]] -> let six = s `app_` i `app_` x-- todo: replace let with better abstraction- in six `app_` eval (Fun na [m, z, s, i, x])- MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i--}--evalFun s@(FunName_ _ f _ _) = f--getFunDef s = case show s of- "unsafeCoerce" -> \case [_, _, x@LCon] -> x; xs -> f xs- "'EqCT" -> \case [t, a, b] -> cstrT'' t a b- "reflCstr" -> \case [a] -> reflCstr a- "coe" -> \case [a, b, t, d] -> evalCoe a b t d- "'T2" -> \case [a, b] -> t2 a b- "t2C" -> \case [a, b] -> t2C a b- "parEval" -> \case [t, a, b] -> parEval t a b- where- parEval _ (LabelEnd x) _ = LabelEnd x- parEval _ _ (LabelEnd x) = LabelEnd x- parEval t a b = ParEval t a b-- -- general compiler primitives- "primAddInt" -> \case [EInt i, EInt j] -> EInt (i + j); xs -> f xs- "primSubInt" -> \case [EInt i, EInt j] -> EInt (i - j); xs -> f xs- "primModInt" -> \case [EInt i, EInt j] -> EInt (i `mod` j); xs -> f xs- "primSqrtFloat" -> \case [EFloat i] -> EFloat $ sqrt i; xs -> f xs- "primRound" -> \case [EFloat i] -> EInt $ round i; xs -> f xs- "primIntToFloat" -> \case [EInt i] -> EFloat $ fromIntegral i; xs -> f xs- "primIntToNat" -> \case [EInt i] -> ENat $ fromIntegral i; xs -> f xs- "primCompareInt" -> \case [EInt x, EInt y] -> mkOrdering $ x `compare` y; xs -> f xs- "primCompareFloat" -> \case [EFloat x, EFloat y] -> mkOrdering $ x `compare` y; xs -> f xs- "primCompareChar" -> \case [EChar x, EChar y] -> mkOrdering $ x `compare` y; xs -> f xs- "primCompareString" -> \case [EString x, EString y] -> mkOrdering $ x `compare` y; xs -> f xs-- -- LambdaCube 3D specific primitives- "PrimGreaterThan" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (>) x y -> r; xs -> f xs- "PrimGreaterThanEqual" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (>=) x y -> r; xs -> f xs- "PrimLessThan" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (<) x y -> r; xs -> f xs- "PrimLessThanEqual" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (<=) x y -> r; xs -> f xs- "PrimEqualV" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (==) x y -> r; xs -> f xs- "PrimNotEqualV" -> \case [_, _, _, _, _, _, _, x, y] | Just r <- twoOpBool (/=) x y -> r; xs -> f xs- "PrimEqual" -> \case [_, _, _, x, y] | Just r <- twoOpBool (==) x y -> r; xs -> f xs- "PrimNotEqual" -> \case [_, _, _, x, y] | Just r <- twoOpBool (/=) x y -> r; xs -> f xs- "PrimSubS" -> \case [_, _, _, _, x, y] | Just r <- twoOp (-) x y -> r; xs -> f xs- "PrimSub" -> \case [_, _, x, y] | Just r <- twoOp (-) x y -> r; xs -> f xs- "PrimAddS" -> \case [_, _, _, _, x, y] | Just r <- twoOp (+) x y -> r; xs -> f xs- "PrimAdd" -> \case [_, _, x, y] | Just r <- twoOp (+) x y -> r; xs -> f xs- "PrimMulS" -> \case [_, _, _, _, x, y] | Just r <- twoOp (*) x y -> r; xs -> f xs- "PrimMul" -> \case [_, _, x, y] | Just r <- twoOp (*) x y -> r; xs -> f xs- "PrimDivS" -> \case [_, _, _, _, _, x, y] | Just r <- twoOp_ (/) div x y -> r; xs -> f xs- "PrimDiv" -> \case [_, _, _, _, _, x, y] | Just r <- twoOp_ (/) div x y -> r; xs -> f xs- "PrimModS" -> \case [_, _, _, _, _, x, y] | Just r <- twoOp_ modF mod x y -> r; xs -> f xs- "PrimMod" -> \case [_, _, _, _, _, x, y] | Just r <- twoOp_ modF mod x y -> r; xs -> f xs- "PrimNeg" -> \case [_, x] | Just r <- oneOp negate x -> r; xs -> f xs- "PrimAnd" -> \case [EBool x, EBool y] -> EBool (x && y); xs -> f xs- "PrimOr" -> \case [EBool x, EBool y] -> EBool (x || y); xs -> f xs- "PrimXor" -> \case [EBool x, EBool y] -> EBool (x /= y); xs -> f xs- "PrimNot" -> \case [_, _, _, EBool x] -> EBool $ not x; xs -> f xs-- _ -> f- where- f = Fun s--cstrT'' TType = cstrT_ TType-cstrT'' t = cstrT t--cstr = cstrT_ TType---cstrT t (UL a) (UL a') | a == a' = Unit-cstrT TNat (ConN "Succ" [a]) (ConN "Succ" [a']) = cstrT TNat a a'-cstrT t (FixLabel _ a) a' = cstrT t a a'-cstrT t a (FixLabel _ a') = cstrT t a a'-cstrT t a a' = CstrT t a a'---- todo: use typ-cstrT_ typ = cstr__ []- where- cstr__ = cstr_-- cstr_ [] (UL a) (UL a') | a == a' = Unit- cstr_ ns (LabelEnd_ k a) a' = cstr_ ns a a'- cstr_ ns a (LabelEnd_ k a') = cstr_ ns a a'- cstr_ ns (FixLabel _ a) a' = cstr_ ns a a'- cstr_ ns a (FixLabel _ a') = cstr_ ns a a'--- cstr_ ns (PMLabel a _) a' = cstr_ ns a a'--- cstr_ ns a (PMLabel a' _) = cstr_ ns a a'--- cstr_ ns TType TType = Unit- cstr_ ns (Con a n xs) (Con a' n' xs') | a == a' && n == n' = foldr t2 Unit $ zipWith (cstr__ ns) xs xs'- cstr_ [] (TyConN "'FrameBuffer" [a, b]) (TyConN "'FrameBuffer" [a', b']) = t2 (cstrT TNat a a') (cstr__ [] b b') -- todo: elim- cstr_ ns (TyCon a xs) (TyCon a' xs') | a == a' = foldr t2 Unit $ zipWith (cstr__ ns) xs xs'--- cstr_ ns (TyCon a []) (TyCon a' []) | a == a' = Unit- cstr_ ns (Var i) (Var i') | i == i', i < length ns = Unit- cstr_ (_: ns) (down 0 -> Just a) (down 0 -> Just a') = cstr__ ns a a'--- cstr_ ((t, t'): ns) (UApp (down 0 -> Just a) (Var 0)) (UApp (down 0 -> Just a') (Var 0)) = traceInj2 (a, "V0") (a', "V0") $ cstr__ ns a a'--- cstr_ ((t, t'): ns) a (UApp (down 0 -> Just a') (Var 0)) = traceInj (a', "V0") a $ cstr__ ns (Lam Visible t a) a'--- cstr_ ((t, t'): ns) (UApp (down 0 -> Just a) (Var 0)) a' = traceInj (a, "V0") a' $ cstr__ ns a (Lam Visible t' a')--- cstr_ ns (Lam b) (Lam b') = cstr__ ((a, a'): ns) b b' -- todo- cstr_ ns (Pi h a b) (Pi h' a' b') | h == h' = t2 (cstr__ ns a a') (cstr__ ((a, a'): ns) b b')--- cstr_ ns (Meta a b) (Meta a' b') = t2 (cstr__ ns a a') (cstr__ ((a, a'): ns) b b')--- cstr_ [] t (Meta a b) = Meta a $ cstr_ [] (up 1 t) b--- cstr_ [] (Meta a b) t = Meta a $ cstr_ [] b (up 1 t)--- cstr_ ns (unApp -> Just (a, b)) (unApp -> Just (a', b')) = traceInj2 (a, show b) (a', show b') $ t2 (cstr__ ns a a') (cstr__ ns b b')--- cstr_ ns (unApp -> Just (a, b)) (unApp -> Just (a', b')) = traceInj2 (a, show b) (a', show b') $ t2 (cstr__ ns a a') (cstr__ ns b b')--- cstr_ ns (Label f xs _) (Label f' xs' _) | f == f' = foldr1 T2 $ zipWith (cstr__ ns) xs xs'-- cstr_ [] (UL (FunN "'VecScalar" [a, b])) (TVec a' b') = t2 (cstrT TNat a a') (cstr__ [] b b')- cstr_ [] (UL (FunN "'VecScalar" [a, b])) (UL (FunN "'VecScalar" [a', b'])) = t2 (cstrT TNat a a') (cstr__ [] b b')- cstr_ [] (UL (FunN "'VecScalar" [a, b])) t@(TTyCon0 n) | isElemTy n = t2 (cstrT TNat a (ENat 1)) (cstr__ [] b t)- cstr_ [] t@(TTyCon0 n) (UL (FunN "'VecScalar" [a, b])) | isElemTy n = t2 (cstrT TNat a (ENat 1)) (cstr__ [] b t)-- cstr_ ns@[] (UL (FunN "'FragOps" [a])) (TyConN "'FragmentOperation" [x]) = cstr__ ns a x- cstr_ ns@[] (UL (FunN "'FragOps" [a])) (TyConN "'Tuple2" [TyConN "'FragmentOperation" [x], TyConN "'FragmentOperation" [y]]) = cstr__ ns a $ TTuple2 x y-- cstr_ ns@[] (TyConN "'Tuple2" [x, y]) (UL (FunN "'JoinTupleType" [x', y'])) = t2 (cstr__ ns x x') (cstr__ ns y y')- cstr_ ns@[] (UL (FunN "'JoinTupleType" [x', y'])) (TyConN "'Tuple2" [x, y]) = t2 (cstr__ ns x' x) (cstr__ ns y' y)- cstr_ ns@[] (UL (FunN "'JoinTupleType" [x', y'])) x@NoTup = t2 (cstr__ ns x' x) (cstr__ ns y' $ TTyCon0 "'Tuple0")-- cstr_ ns@[] (x@NoTup) (UL (FunN "'InterpolatedType" [x'])) = cstr__ ns (TTyCon "'Interpolated" (TType :~> TType) [x]) x'---- cstr_ [] (TyConN "'FrameBuffer" [a, b]) (UL (FunN "'TFFrameBuffer" [TyConN "'Image" [a', b']])) = T2 (cstrT TNat a a') (cstr__ [] b b')-- cstr_ [] a@App{} a'@App{} = CstrT TType a a'- cstr_ [] a@CFun a'@CFun = CstrT TType a a'- cstr_ [] a@LCon a'@CFun = CstrT TType a a'- cstr_ [] a@LCon a'@App{} = CstrT TType a a'- cstr_ [] a@CFun a'@LCon = CstrT TType a a'- cstr_ [] a@App{} a'@LCon = CstrT TType a a'- cstr_ [] a@PMLabel{} a' = CstrT TType a a'- cstr_ [] a a'@PMLabel{} = CstrT TType a a'- cstr_ [] a a' | isVar a || isVar a' = CstrT TType a a'- cstr_ ns a a' = Empty $ unlines [ "can not unify"- , ppShow a- , "with"- , ppShow a'- ]-{---- unApp (UApp a b) | isInjective a = Just (a, b) -- TODO: injectivity check- unApp (Con a xs@(_:_)) = Just (Con a (init xs), last xs)- unApp (TyCon a xs@(_:_)) = Just (TyCon a (init xs), last xs)- unApp _ = Nothing--}- isInjective _ = True--False-- isVar Var{} = True- isVar (App a b) = isVar a- isVar _ = False-- traceInj2 (a, a') (b, b') c | debug && (susp a || susp b) = trace_ (" inj'? " ++ show a ++ " : " ++ a' ++ " ---- " ++ show b ++ " : " ++ b') c- traceInj2 _ _ c = c- traceInj (x, y) z a | debug && susp x = trace_ (" inj? " ++ show x ++ " : " ++ y ++ " ---- " ++ show z) a- traceInj _ _ a = a-- susp Con{} = False- susp TyCon{} = False- susp _ = True-- isElemTy n = n `elem` ["'Bool", "'Float", "'Int"]--reflCstr = \case-{-- Unit -> TT- TType -> TT -- ?- Con n xs -> foldl (t2C te{-todo: more precise env-}) TT $ map (reflCstr te{-todo: more precise env-}) xs- TyCon n xs -> foldl (t2C te{-todo: more precise env-}) TT $ map (reflCstr te{-todo: more precise env-}) xs- x -> {-error $ "reflCstr: " ++ show x-} ReflCstr x--}- x -> TT--t2C TT TT = TT-t2C a b = T2C a b--t2 Unit a = a-t2 a Unit = a-t2 (Empty a) (Empty b) = Empty (a <> b)-t2 (Empty s) _ = Empty s-t2 _ (Empty s) = Empty s-t2 a b = T2 a b--oneOp :: (forall a . Num a => a -> a) -> Exp -> Maybe Exp-oneOp f = oneOp_ f f--oneOp_ f _ (EFloat x) = Just $ EFloat $ f x-oneOp_ _ f (EInt x) = Just $ EInt $ f x-oneOp_ _ _ _ = Nothing--twoOp :: (forall a . Num a => a -> a -> a) -> Exp -> Exp -> Maybe Exp-twoOp f = twoOp_ f f--twoOp_ f _ (EFloat x) (EFloat y) = Just $ EFloat $ f x y-twoOp_ _ f (EInt x) (EInt y) = Just $ EInt $ f x y-twoOp_ _ _ _ _ = Nothing--modF x y = x - fromIntegral (floor (x / y)) * y--twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp-twoOpBool f (EFloat x) (EFloat y) = Just $ EBool $ f x y-twoOpBool f (EInt x) (EInt y) = Just $ EBool $ f x y-twoOpBool f (EString x) (EString y) = Just $ EBool $ f x y-twoOpBool f (EChar x) (EChar y) = Just $ EBool $ f x y-twoOpBool f (ENat x) (ENat y) = Just $ EBool $ f x y-twoOpBool _ _ _ = Nothing--app_ :: Exp -> Exp -> Exp-app_ (Lam x) a = subst 0 a x-app_ (Con s n xs) a = if n < conParams s then Con s (n+1) xs else Con s n (xs ++ [a])-app_ (TyCon s xs) a = TyCon s (xs ++ [a])-app_ (Label lk x e) a = label lk (app_ x a) $ app_ e a-app_ (LabelEnd_ k x) a = LabelEnd_ k (app_ x a) -- ???-app_ (Neut f) a = neutApp f a--neutApp (PMLabel_ f i xs e) a- = pmLabel f (i-1) (xs ++ [a]) (app_ e a)--- | i == 0 = app_ (pmLabel f i xs e) a-neutApp f a = Neut $ App_ f a---------------------------------------------------------------------------------- constraints env--data CEnv a- = MEnd a- | Meta Exp (CEnv a)- | Assign !Int ExpType (CEnv a) -- De Bruijn index decreasing assign reservedOp, only for metavariables (non-recursive)- deriving (Show, Functor)--instance (Subst Exp a) => Up (CEnv a) where- up1_ i = \case- MEnd a -> MEnd $ up1_ i a- Meta a b -> Meta (up1_ i a) (up1_ (i+1) b)- Assign j a b -> handleLet i j $ \i' j' -> assign j' (up1_ i' a) (up1_ i' b)- where- handleLet i j f- | i > j = f (i-1) j- | i <= j = f i (j+1)-- used i a = error "used @(CEnv _)"-- fold _ _ _ = error "fold @(CEnv _)"-- maxDB_ _ = error "maxDB_ @(CEnv _)"--instance (Subst Exp a) => Subst Exp (CEnv a) where- subst i x = \case- MEnd a -> MEnd $ subst i x a- Meta a b -> Meta (subst i x a) (subst (i+1) (up 1 x) b)- Assign j a b- | j > i, Just a' <- down i a -> assign (j-1) a' (subst i (subst (j-1) (fst a') x) b)- | j > i, Just x' <- down (j-1) x -> assign (j-1) (subst i x' a) (subst i x' b)- | j < i, Just a' <- down (i-1) a -> assign j a' (subst (i-1) (subst j (fst a') x) b)- | j < i, Just x' <- down j x -> assign j (subst (i-1) x' a) (subst (i-1) x' b)- | j == i -> Meta (cstrT'' (snd a) x $ fst a) $ up1_ 0 b----assign :: (Int -> Exp -> CEnv Exp -> a) -> (Int -> Exp -> CEnv Exp -> a) -> Int -> Exp -> CEnv Exp -> a-swapAssign _ clet i (Var j, t) b | i > j = clet j (Var (i-1), t) $ subst j (Var (i-1)) $ up1_ i b-swapAssign clet _ i a b = clet i a b--assign = swapAssign Assign Assign----------------------------------------------------------------------------------- environments---- SExp + Exp zipper-data Env- = EBind1 SI Binder Env SExp2 -- zoom into first parameter of SBind- | EBind2_ SI Binder Type Env -- zoom into second parameter of SBind- | EApp1 SI Visibility Env SExp2- | EApp2 SI Visibility ExpType Env- | ELet1 LI Env SExp2- | ELet2 LI ExpType Env- | EGlobal String{-full source of current module-} GlobalEnv [Stmt]- | ELabelEnd Env-- | EAssign Int ExpType Env- | CheckType_ SI Type Env- | CheckIType SExp2 Env--- | CheckSame Exp Env- | CheckAppType SI Visibility Type Env SExp2 --pattern CheckAppType _ h t te b = EApp1 _ h (CheckType t te) b- deriving Show--pattern EBind2 b e env <- EBind2_ _ b e env where EBind2 b e env = EBind2_ (debugSI "6") b e env-pattern CheckType e env <- CheckType_ _ e env where CheckType e env = CheckType_ (debugSI "7") e env--parent = \case- EAssign _ _ x -> Right x- EBind2 _ _ x -> Right x- EBind1 _ _ x _ -> Right x- EApp1 _ _ x _ -> Right x- EApp2 _ _ _ x -> Right x- ELet1 _ x _ -> Right x- ELet2 _ _ x -> Right x- CheckType _ x -> Right x- CheckIType _ x -> Right x--- CheckSame _ x -> Right x- CheckAppType _ _ _ x _ -> Right x- ELabelEnd x -> Right x- EGlobal s x _ -> Left (s, x)---------------------------------------------------------------------------------- simple typing--litType = \case- LInt _ -> TInt- LFloat _ -> TFloat- LString _ -> TString- LChar _ -> TChar--class NType a where nType :: a -> Type--instance NType FunName where nType (FunName _ _ t) = t-instance NType ConName where nType (ConName _ _ _ _ t) = t-instance NType TyConName where nType (TyConName _ _ _ t _ _) = t-instance NType CaseFunName where nType (CaseFunName _ t _) = t-instance NType TyCaseFunName where nType (TyCaseFunName _ t) = t--neutType te = \case- App_ f x -> appTy (neutType te f) x- Var_ i -> snd $ varType "C" i te- Fun_ s ts -> foldl appTy (nType s) ts- CaseFun_ s ts n -> appTy (foldl appTy (nType s) $ makeCaseFunPars te n ++ ts) (Neut n)- TyCaseFun_ s [m, t, f] n -> foldl appTy (nType s) [m, t, Neut n, f]- PMLabel_ s _ a _ -> foldl appTy (nType s) a--appTy (Pi _ a b) x = subst 0 x b-appTy t x = error $ "appTy: " ++ show t---------------------------------------------------------------------------------- inference--type TCM m = ExceptT String (WriterT Infos m)----runTCM = either error id . runExcept--expAndType s (e, t, si) = (e, t)---- todo: do only if NoTypeNamespace extension is not on-lookupName s@('\'':s') m = expAndType s <$> (Map.lookup s m `mplus` Map.lookup s' m)-lookupName s m = expAndType s <$> Map.lookup s m---elemIndex' s@('\'':s') m = elemIndex s m `mplus` elemIndex s' m---elemIndex' s m = elemIndex s m--getDef te si s = maybe (throwError $ "can't find: " ++ s ++ " in " ++ showSI te si {- ++ "\nitems:\n" ++ intercalate ", " (take' "..." 10 $ Map.keys $ snd $ extractEnv te)-}) return (lookupName s $ snd $ extractEnv te)-{--take' e n xs = case splitAt n xs of- (as, []) -> as- (as, _) -> as ++ [e]--}-showSI :: Env -> SI -> String-showSI e = showSI_ (fst $ extractEnv e)--type ExpType' = CEnv ExpType--inferN :: forall m . Monad m => TraceLevel -> Env -> SExp2 -> TCM m ExpType'-inferN tracelevel = infer where-- infer :: Env -> SExp2 -> TCM m ExpType'- infer te exp = (if tracelevel >= 1 then trace_ ("infer: " ++ showEnvSExp te exp) else id) $ (if debug then fmap (fmap{-todo-} $ recheck' "infer" te) else id) $ case exp of- SAnn x t -> checkN (CheckIType x te) t TType- SLabelEnd x -> infer (ELabelEnd te) x- SVar (si, _) i -> focus_' te exp (Var i, snd $ varType "C2" i te)- SLit si l -> focus_' te exp (ELit l, litType l)- STyped si et -> focus_' te exp et- SGlobal (si, s) -> focus_' te exp =<< getDef te si s- SApp si h a b -> infer (EApp1 (si `validate` [sourceInfo a, sourceInfo b]) h te b) a- SLet le a b -> infer (ELet1 le te b{-in-}) a{-let-} -- infer te SLamV b `SAppV` a)- SBind si h _ a b -> infer ((if h /= BMeta then CheckType_ (sourceInfo exp) TType else id) $ EBind1 si h te $ (if isPi h then TyType else id) b) a-- checkN :: Env -> SExp2 -> Exp -> TCM m ExpType'- checkN te x t = (if tracelevel >= 1 then trace_ $ "check: " ++ showEnvSExpType te x t else id) $ checkN_ te x t-- checkN_ te e t- -- temporal hack- | x@(SGlobal (si, MatchName n)) `SAppV` SLamV (Wildcard_ siw _) `SAppV` a `SAppV` SVar siv v `SAppV` b <- e- = infer te $ x `SAppV` SLam Visible SType (STyped mempty (subst (v+1) (Var 0) $ up 1 t, TType)) `SAppV` a `SAppV` SVar siv v `SAppV` b- -- temporal hack- | x@(SGlobal (si, "'NatCase")) `SAppV` SLamV (Wildcard_ siw _) `SAppV` a `SAppV` b `SAppV` SVar siv v <- e- = infer te $ x `SAppV` STyped mempty (Lam $ subst (v+1) (Var 0) $ up 1 t, TNat :~> TType) `SAppV` a `SAppV` b `SAppV` SVar siv v-{-- -- temporal hack- | x@(SGlobal "'VecSCase") `SAppV` SLamV (SLamV (Wildcard _)) `SAppV` a `SAppV` b `SAppV` c `SAppV` SVar v <- e- = infer te $ x `SAppV` (SLamV (SLamV (STyped (subst (v+1) (Var 0) $ up 2 t, TType)))) `SAppV` a `SAppV` b `SAppV` c `SAppV` SVar v--}- -- temporal hack- | SGlobal (si, "undefined") <- e = focus_' te e (Undef t, t)- | SLabelEnd x <- e = checkN (ELabelEnd te) x t- | SApp si h a b <- e = infer (CheckAppType si h t te b) a- | SLam h a b <- e, Pi h' x y <- t, h == h' = do- tellType te e t- let same = checkSame te a x- if same then checkN (EBind2 (BLam h) x te) b y else error $ "checkSame:\n" ++ show a ++ "\nwith\n" ++ showEnvExp te (x, TType)- | Pi Hidden a b <- t, notHiddenLam e = checkN (EBind2 (BLam Hidden) a te) (up1 e) b- | otherwise = infer (CheckType_ (sourceInfo e) t te) e- where- -- todo- notHiddenLam = \case- SLam Visible _ _ -> True- SGlobal (si,s) | (Lam _, Pi Hidden _ _) <- fromMaybe (error $ "infer: can't find: " ++ s) $ lookupName s $ snd $ extractEnv te -> False- | otherwise -> True- _ -> False-{-- -- todo- checkSame te (Wildcard _) a = return (te, True)- checkSame te x y = do- (ex, _) <- checkN te x TType- return $ ex == y--}- checkSame te (Wildcard _) a = True- checkSame te (SGlobal (_,"'Type")) TType = True- checkSame te SType TType = True- checkSame te (SBind _ BMeta _ SType (STyped _ (Var 0, _))) a = True- checkSame te a b = error $ "checkSame: " ++ show (a, b)-- hArgs (Pi Hidden _ b) = 1 + hArgs b- hArgs _ = 0-- focus_' env si eet = tellType env si (snd eet) >> focus_ env eet-- focus_ :: Env -> ExpType -> TCM m ExpType'- focus_ env eet@(e, et) = (if tracelevel >= 1 then trace_ $ "focus: " ++ showEnvExp env eet else id) $ (if debug then fmap (fmap{-todo-} $ recheck' "focus" env) else id) $ case env of- ELabelEnd te -> focus_ te (LabelEnd e, et)--- CheckSame x te -> focus_ (EBind2_ (debugSI "focus_ CheckSame") BMeta (cstr x e) te) $ up 1 eet- CheckAppType si h t te b -- App1 h (CheckType t te) b- | Pi h' x (down 0 -> Just y) <- et, h == h' -> case t of- Pi Hidden t1 t2 | h == Visible -> focus_ (EApp1 si h (CheckType_ (sourceInfo b) t te) b) eet -- <<e>> b : {t1} -> {t2}- _ -> focus_ (EBind2_ (sourceInfo b) BMeta (cstr t y) $ EApp1 si h te b) $ up 1 eet- | otherwise -> focus_ (EApp1 si h (CheckType_ (sourceInfo b) t te) b) eet- EApp1 si h te b- | Pi h' x y <- et, h == h' -> checkN (EApp2 si h eet te) b x- | Pi Hidden x y <- et, h == Visible -> focus_ (EApp1 mempty Hidden env $ Wildcard $ Wildcard SType) eet -- e b --> e _ b--- | CheckType (Pi Hidden _ _) te' <- te -> error "ok"--- | CheckAppType Hidden _ te' _ <- te -> error "ok"- | otherwise -> infer (CheckType_ (sourceInfo b) (Var 2) $ cstr' h (up 2 et) (Pi Visible (Var 1) (Var 1)) (up 2 e) $ EBind2_ (sourceInfo b) BMeta TType $ EBind2_ (sourceInfo b) BMeta TType te) (up 3 b)- where- cstr' h x y e = EApp2 mempty h (evalCoe (up 1 x) (up 1 y) (Var 0) (up 1 e), up 1 y) . EBind2_ (sourceInfo b) BMeta (cstr x y)- ELet2 le (x{-let-}, xt) te -> focus_ te $ subst 0 (mkELet le x xt){-let-} eet{-in-}- CheckIType x te -> checkN te x e- CheckType_ si t te- | hArgs et > hArgs t- -> focus_ (EApp1 mempty Hidden (CheckType_ si t te) $ Wildcard $ Wildcard SType) eet- | hArgs et < hArgs t, Pi Hidden t1 t2 <- t- -> focus_ (CheckType_ si t2 $ EBind2 (BLam Hidden) t1 te) eet- | otherwise -> focus_ (EBind2_ si BMeta (cstr t et) te) $ up 1 eet- EApp2 si h (a, at) te -> focus_' te si (app_ a e, appTy at e) -- h??- EBind1 si h te b -> infer (EBind2_ (sourceInfo b) h e te) b- EBind2_ si (BLam h) a te -> focus_ te $ lamPi h a eet- EBind2_ si (BPi h) a te -> focus_' te si (Pi h a e, TType)- _ -> focus2 env $ MEnd eet-- focus2 :: Env -> CEnv ExpType -> TCM m ExpType'- focus2 env eet = case env of- ELet1 le te b{-in-} -> infer (ELet2 le (replaceMetas' eet{-let-}) te) b{-in-}- EBind2_ si BMeta tt te- | Unit <- tt -> refocus te $ subst 0 TT eet- | Empty msg <- tt -> throwError $ "type error: " ++ msg ++ "\nin " ++ showSI te si ++ "\n"-- todo: better error msg- | T2 x y <- tt, let te' = EBind2_ si BMeta (up 1 y) $ EBind2_ si BMeta x te- -> refocus te' $ subst 2 (t2C (Var 1) (Var 0)) $ up 2 eet- | CstrT t a b <- tt, a == b -> refocus te $ subst 0 TT eet- | CstrT t a b <- tt, Just r <- cst (a, t) b -> r- | CstrT t a b <- tt, Just r <- cst (b, t) a -> r- | isCstr tt, EBind2 h x te' <- te{-, h /= BMeta todo: remove-}, Just x' <- down 0 tt, x == x'- -> refocus te $ subst 1 (Var 0) eet- | EBind2 h x te' <- te, h /= BMeta, Just b' <- down 0 tt- -> refocus (EBind2_ si h (up 1 x) $ EBind2_ si BMeta b' te') $ subst 2 (Var 0) $ up 1 eet- | ELet2 le (x, xt) te' <- te, Just b' <- down 0 tt- -> refocus (ELet2 le (up 1 x, up 1 xt) $ EBind2_ si BMeta b' te') $ subst 2 (Var 0) $ up 1 eet- | EBind1 si h te' x <- te -> refocus (EBind1 si h (EBind2_ si BMeta tt te') $ up1_ 1 x) eet- | ELet1 le te' x <- te, floatLetMeta $ snd $ replaceMetas' $ Meta tt $ eet- -> refocus (ELet1 le (EBind2_ si BMeta tt te') $ up1_ 1 x) eet- | CheckAppType si h t te' x <- te -> refocus (CheckAppType si h (up 1 t) (EBind2_ si BMeta tt te') $ up1 x) eet- | EApp1 si h te' x <- te -> refocus (EApp1 si h (EBind2_ si BMeta tt te') $ up1 x) eet- | EApp2 si h x te' <- te -> refocus (EApp2 si h (up 1 x) $ EBind2_ si BMeta tt te') eet- | CheckType_ si t te' <- te -> refocus (CheckType_ si (up 1 t) $ EBind2_ si BMeta tt te') eet--- | CheckIType x te' <- te -> refocus (CheckType_ si (up 1 t) $ EBind2_ si BMeta tt te') eet- | ELabelEnd te' <- te -> refocus (ELabelEnd $ EBind2_ si BMeta tt te') eet- | otherwise -> focus2 te $ Meta tt eet- where- refocus = refocus_ focus2- cst :: ExpType -> Exp -> Maybe (TCM m ExpType')- cst x = \case- Var i | fst (varType "X" i te) == BMeta- , Just y <- down i x- -> Just $ join swapAssign (\i x -> refocus $ EAssign i x te) i y $ subst 0 {-ReflCstr y-}TT $ subst (i+1) (fst $ up 1 y) eet- _ -> Nothing-- EAssign i b te -> case te of- EBind2_ si h x te' | i > 0, Just b' <- down 0 b- -> refocus' (EBind2_ si h (subst (i-1) (fst b') x) (EAssign (i-1) b' te')) eet- ELet2 le (x, xt) te' | i > 0, Just b' <- down 0 b- -> refocus' (ELet2 le (subst (i-1) (fst b') x, subst (i-1) (fst b') xt) (EAssign (i-1) b' te')) eet- ELet1 le te' x -> refocus' (ELet1 le (EAssign i b te') $ substS (i+1) (up 1 b) x) eet- EBind1 si h te' x -> refocus' (EBind1 si h (EAssign i b te') $ substS (i+1) (up 1 b) x) eet- CheckAppType si h t te' x -> refocus' (CheckAppType si h (subst i (fst b) t) (EAssign i b te') $ substS i b x) eet- EApp1 si h te' x -> refocus' (EApp1 si h (EAssign i b te') $ substS i b x) eet- EApp2 si h x te' -> refocus' (EApp2 si h (subst i (fst b) x) $ EAssign i b te') eet- CheckType_ si t te' -> refocus' (CheckType_ si (subst i (fst b) t) $ EAssign i b te') eet- ELabelEnd te' -> refocus' (ELabelEnd $ EAssign i b te') eet- EAssign j a te' | i < j- -> refocus' (EAssign (j-1) (subst i (fst b) a) $ EAssign i (up1_ (j-1) b) te') eet- t | Just te' <- pull i te -> refocus' te' eet- | otherwise -> swapAssign (\i x -> focus2 te . Assign i x) (\i x -> refocus' $ EAssign i x te) i b eet- -- todo: CheckSame Exp Env- where- refocus' = fix refocus_- pull i = \case- EBind2 BMeta _ te | i == 0 -> Just te- EBind2_ si h x te -> EBind2_ si h <$> down (i-1) x <*> pull (i-1) te- EAssign j b te -> EAssign (if j <= i then j else j-1) <$> down i b <*> pull (if j <= i then i+1 else i) te- _ -> Nothing-- EGlobal{} -> return eet- _ -> case eet of- MEnd x -> throwError_ $ "focus todo: " ++ ppShow x- _ -> throwError_ $ "focus checkMetas: " ++ ppShow env ++ "\n" ++ ppShow (fst <$> eet)- where- refocus_ :: (Env -> CEnv ExpType -> TCM m ExpType') -> Env -> CEnv ExpType -> TCM m ExpType'- refocus_ _ e (MEnd at) = focus_ e at- refocus_ f e (Meta x at) = f (EBind2 BMeta x e) at- refocus_ _ e (Assign i x at) = focus2 (EAssign i x e) at-- replaceMetas' = replaceMetas $ lamPi Hidden--lamPi h = (***) <$> (\a b -> Lam b) <*> Pi h--replaceMetas bind = \case- Meta a t -> bind a $ replaceMetas bind t- Assign i x t | x' <- up1_ i x -> bind (cstrT'' (snd x') (Var i) $ fst x') . up 1 . up1_ i $ replaceMetas bind t- MEnd t -> t---isCstr CstrT{} = True-isCstr (UL (FunN s _)) = s `elem` ["'Eq", "'Ord", "'Num", "'CNum", "'Signed", "'Component", "'Integral", "'NumComponent", "'Floating"] -- todo: use Constraint type to decide this-isCstr (UL c) = {- trace_ (ppShow c ++ show c) $ -} False---------------------------------------------------------------------------------- re-checking--type Message = String--recheck :: Message -> Env -> ExpType -> ExpType-recheck msg e = recheck' msg e---- todo: check type also-recheck' :: Message -> Env -> ExpType -> ExpType-recheck' msg' e (x, xt) = (recheck_ "main" (checkEnv e) (x, xt), xt)- where- checkEnv = \case- e@EGlobal{} -> e- EBind1 si h e b -> EBind1 si h (checkEnv e) b- EBind2_ si h t e -> EBind2_ si h (checkType e t) $ checkEnv e -- E [\(x :: t) -> e] -> check E [t]- ELet1 le e b -> ELet1 le (checkEnv e) b- ELet2 le x e -> ELet2 le (recheck'' "env" e x) $ checkEnv e- EApp1 si h e b -> EApp1 si h (checkEnv e) b- EApp2 si h a e -> EApp2 si h (recheck'' "env" e a) $ checkEnv e -- E [a x] -> check- EAssign i x e -> EAssign i (recheck'' "env" e $ up1_ i x) $ checkEnv e -- __ <i := x>- CheckType_ si x e -> CheckType_ si (checkType e x) $ checkEnv e--- CheckSame x e -> CheckSame (recheck'' "env" e x) $ checkEnv e- CheckAppType si h x e y -> CheckAppType si h (checkType e x) (checkEnv e) y-- recheck'' msg te a@(x, xt) = (recheck_ msg te a, xt)- checkType te e = recheck_ "check" te (e, TType)-- recheck_ msg te = \case- (Var k, zt) -> Var k -- todo: check var type- (Lam b, Pi h a bt) -> Lam $ recheck_ "9" (EBind2 (BLam h) a te) (b, bt)- (Pi h a b, TType) -> Pi h (checkType te a) $ checkType (EBind2 (BPi h) a te) b- (ELit l, zt) -> ELit l -- todo: check literal type- (TType, TType) -> TType- (Neut (App_ a b), zt)- | (Neut a', at) <- recheck'' "app1" te (Neut a, neutType te a)- -> checkApps [] zt (Neut . App_ a' . head) te at [b]- (Con s n as, zt) -> checkApps [] zt (Con s n . drop (conParams s)) te (nType s) $ mkConPars n zt ++ as- (TyCon s as, zt) -> checkApps [] zt (TyCon s) te (nType s) as- (Fun s as, zt) -> checkApps [] zt (Fun s) te (nType s) as- (CaseFun s@(CaseFunName _ t pars) as n, zt) -> checkApps [] zt (\xs -> evalCaseFun s (init $ drop pars xs) (last xs)) te (nType s) (makeCaseFunPars te n ++ as ++ [Neut n])- (TyCaseFun s [m, t, f] n, zt) -> checkApps [] zt (\[m, t, n, f] -> evalTyCaseFun s [m, t, f] n) te (nType s) [m, t, Neut n, f]- (Label lk a x, zt) -> Label lk (recheck_ msg te (a, zt)) x- (PMLabel f i a x, zt) -> checkApps [] zt (\xs -> PMLabel f i xs x) te (nType f) a- (LabelEnd_ k x, zt) -> LabelEnd_ k $ recheck_ msg te (x, zt)- where- checkApps acc zt f _ t [] | t == zt = f $ reverse acc- checkApps acc zt f te t@(Pi h x y) (b_: xs) = checkApps (b: acc) zt f te (appTy t b) xs where b = recheck_ "checkApps" te (b_, x)- checkApps acc zt f te t _ = error_ $ "checkApps " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (t, TType) ++ "\n\n" ++ showEnvExp e (x, xt)-- getNeut (Neut a) = a---- Ambiguous: (Int ~ F a) => Int--- Not ambiguous: (Show a, a ~ F b) => b-ambiguityCheck :: String -> Exp -> Maybe String-ambiguityCheck s ty = case ambigVars ty of- [] -> Nothing- err -> Just $ s ++ " has ambiguous type:\n" ++ ppShow ty ++ "\nproblematic vars:\n" ++ show err--ambigVars :: Exp -> [(Int, Exp)]-ambigVars ty = [(n, c) | (n, c) <- hid, not $ any (`Set.member` defined) $ Set.insert n $ free c]- where- (defined, hid, i) = compDefined False ty--floatLetMeta :: Exp -> Bool-floatLetMeta ty = (i-1) `Set.member` defined- where- (defined, hid, i) = compDefined True ty--compDefined b ty = (defined, hid, i)- where- defined = dependentVars hid $ Set.map (if b then (+i) else id) $ free ty-- i = length hid_- hid = zipWith (\k t -> (k, up (k+1) t)) (reverse [0..i-1]) hid_- (hid_, ty') = hiddenVars ty--hiddenVars (Pi Hidden a b) = first (a:) $ hiddenVars b-hiddenVars t = ([], t)---- compute dependent type vars in constraints--- Example: dependentVars [(a, b) ~ F b c, d ~ F e] [c] == [a,b,c]-dependentVars :: [(Int, Exp)] -> Set.Set Int -> Set.Set Int-dependentVars ie = cycle mempty- where- freeVars = free-- cycle acc s- | Set.null s = acc- | otherwise = cycle (acc <> s) (grow s Set.\\ acc)-- grow = flip foldMap ie $ \case- (n, t) -> (Set.singleton n <-> freeVars t) <> case t of- CstrT _{-todo-} ty f -> freeVars ty <-> freeVars f- CSplit a b c -> freeVars a <-> (freeVars b <> freeVars c)- _ -> mempty- where- a --> b = \s -> if Set.null $ a `Set.intersection` s then mempty else b- a <-> b = (a --> b) <> (b --> a)----------------------------------------------------------------------------------- global env--type GlobalEnv = Map.Map SName (Exp, Type, SI)---- monad used during elaborating statments -- TODO: use zippers instead-type ElabStmtM m = ReaderT (Extensions, String{-full source-}) (StateT GlobalEnv (ExceptT String (WriterT Infos m)))--extractEnv :: Env -> (String, GlobalEnv)-extractEnv = either id extractEnv . parent--initEnv :: GlobalEnv-initEnv = Map.fromList- [ (,) "'Type" (TType, TType, debugSI "source-of-Type")- ]--extractDesugarInfo :: GlobalEnv -> DesugarInfo-extractDesugarInfo ge =- ( Map.fromList- [ (n, f) | (n, (d, _, si)) <- Map.toList ge, f <- maybeToList $ case UL' d of- Con (ConName _ f _ _ _) 0 [] -> f- TyCon (TyConName _ f _ _ _ _) [] -> f- (getLams -> UL (getLams -> Fun (FunName _ f _) _)) -> f- Fun (FunName _ f _) [] -> f- _ -> Nothing- ]- , Map.fromList $- [ (n, Left ((t, inum), map f cons))- | (n, (UL' (Con cn 0 []), _, si)) <- Map.toList ge, let TyConName t _ inum _ cons _ = conTypeName cn- ] ++- [ (n, Right $ pars t)- | (n, (UL' (TyCon (TyConName _ _ _ t _ _) []), _, _)) <- Map.toList ge- ]- )- where- f (ConName n _ _ _ ct) = (n, pars ct)- pars = length . filter ((==Visible) . fst) . fst . getParams---------------------------------------------------------------------------------- infos--newtype Infos = Infos (Map.Map Range (Set.Set String))- deriving (NFData)--instance Monoid Infos where- mempty = Infos mempty- Infos x `mappend` Infos y = Infos $ Map.unionWith mappend x y--mkInfoItem (RangeSI r) i = Infos $ Map.singleton r $ Set.singleton i-mkInfoItem _ _ = mempty--listInfos (Infos m) = [(r, Set.toList i) | (r, i) <- Map.toList m]---------------------------------------------------------------------------------- inference for statements--handleStmt :: MonadFix m => [Stmt] -> Stmt -> ElabStmtM m ()-handleStmt defs = \case- Primitive n mf (trSExp' -> t_) -> do- t <- inferType tr =<< ($ t_) <$> addF- tellStmtType (fst n) t- addToEnv n $ flip (,) t $ lamify t $ Fun (FunName (snd n) mf t)- Let n mf mt ar t_ -> do- af <- addF- let t__ = maybe id (flip SAnn . af) mt t_- (x, t) <- inferTerm (snd n) tr id $ trSExp' $ if usedS n t__ then SBuiltin "primFix" `SAppV` SLamV (substSG0 n t__) else t__- tellStmtType (fst n) t- addToEnv n (mkELet (True, n, SData mf, ar) x t, t)- PrecDef{} -> return ()- Data s (map (second trSExp') -> ps) (trSExp' -> t_) addfa (map (second trSExp') -> cs) -> do- exs <- asks fst- af <- if addfa then gets $ addForalls exs . (snd s:) . defined' else return id- vty <- inferType tr $ addParamsS ps t_- tellStmtType (fst s) vty- let- pnum' = length $ filter ((== Visible) . fst) ps- inum = arity vty - length ps-- mkConstr j (cn, af -> ct)- | c == SGlobal s && take pnum' xs == downToS (length . fst . getParamsS $ ct) pnum'- = do- cty <- removeHiddenUnit <$> inferType tr (addParamsS [(Hidden, x) | (Visible, x) <- ps] ct)- tellStmtType (fst cn) cty- let pars = zipWith (\x -> second $ STyped (debugSI "mkConstr1") . flip (,) TType . up_ (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty- act = length . fst . getParams $ cty- acts = map fst . fst . getParams $ cty- conn = conName (snd cn) (listToMaybe [f | PrecDef n f <- defs, n == cn]) j cty- addToEnv cn (Con conn 0 [], cty)- return ( conn- , addParamsS pars- $ foldl SAppV (SVar (debugSI "22", ".cs") $ j + length pars) $ drop pnum' xs ++ [apps' (SGlobal cn) (zip acts $ downToS (j+1+length pars) (length ps) ++ downToS 0 (act- length ps))]- )- | otherwise = throwError "illegal data definition (parameters are not uniform)" -- ++ show (c, cn, take pnum' xs, act)- where- (c, map snd -> xs) = getApps $ snd $ getParamsS ct-- motive = addParamsS (replicate inum (Visible, Wildcard SType)) $- SPi Visible (apps' (SGlobal s) $ zip (map fst ps) (downToS inum $ length ps) ++ zip (map fst $ fst $ getParamsS t_) (downToS 0 inum)) SType-- mdo- let tcn = TyConName (snd s) Nothing inum vty (map fst cons) cfn- let cfn = CaseFunName (snd s) ct $ length ps- addToEnv s (TyCon tcn [], vty)- cons <- zipWithM mkConstr [0..] cs- ct <- inferType tr- ( (\x -> traceD ("type of case-elim before elaboration: " ++ ppShow x) x) $ addParamsS- ( [(Hidden, x) | (_, x) <- ps]- ++ (Visible, motive)- : map ((,) Visible . snd) cons- ++ replicate inum (Hidden, Wildcard SType)- ++ [(Visible, apps' (SGlobal s) $ zip (map fst ps) (downToS (inum + length cs + 1) $ length ps) ++ zip (map fst $ fst $ getParamsS t_) (downToS 0 inum))]- )- $ foldl SAppV (SVar (debugSI "23", ".ct") $ length cs + inum + 1) $ downToS 1 inum ++ [SVar (debugSI "24", ".24") 0]- )- addToEnv (fst s, caseName (snd s)) (lamify ct $ \xs -> evalCaseFun cfn (init $ drop (length ps) xs) (last xs), ct)- let ps' = fst $ getParams vty- t = (TType :~> TType)- :~> addParams ps' (Var (length ps') `app_` TyCon tcn (downTo 0 $ length ps'))- :~> TType- :~> Var 2 `app_` Var 0- :~> Var 3 `app_` Var 1- addToEnv (fst s, MatchName (snd s)) (lamify t $ \[m, tr, n, f] -> evalTyCaseFun (TyCaseFunName (snd s) t) [m, tr, f] n, t)-- stmt -> error $ "handleStmt: " ++ show stmt--mkELet (False, n, mf, ar) x xt = x-mkELet (True, n, SData mf, ar) x t{-type of x-} = term- where- term = pmLabel (FunName (snd n) mf t) (addLams'' ar t) [] $ par ar t x 0-- addLams'' [] _ = 0- addLams'' (h: ar) (Pi h' d t) | h == h' = 1 + addLams'' ar t- addLams'' ar@(Visible: _) (Pi h@Hidden d t) = 1 + addLams'' ar t-- addLams' [] _ i = Fun (FunName (snd n) mf t) $ downTo 0 i- addLams' (h: ar) (Pi h' d t) i | h == h' = Lam $ addLams' ar t (i+1)- addLams' ar@(Visible: _) (Pi h@Hidden d t) i = Lam $ addLams' ar t (i+1)-- par ar tt (FunN "primFix" [_, f]) i = f `app_` label LabelFix (addLams' ar tt i) (foldl app_ term $ downTo 0 i)- par ar (Pi Hidden k tt) (Lam z) i = Lam $ par (dropHidden ar) tt z (i+1)- where- dropHidden (Hidden: ar) = ar- dropHidden ar = ar- par ar t x _ = x--removeHiddenUnit (Pi Hidden Unit (down 0 -> Just t)) = removeHiddenUnit t-removeHiddenUnit (Pi h a b) = Pi h a $ removeHiddenUnit b-removeHiddenUnit t = t--addParams ps t = foldr (uncurry Pi) t ps--addLams ps t = foldr (uncurry $ \h a b -> Lam b) t ps--lamify t x = addLams (fst $ getParams t) $ x $ downTo 0 $ arity t--{--getApps' = second reverse . run where- run (App a b) = second (b:) $ run a- run x = (x, [])--}-arity :: Exp -> Int-arity = length . fst . getParams--getParams :: Exp -> ([(Visibility, Exp)], Exp)-getParams (UL' (Pi h a b)) = first ((h, a):) $ getParams b-getParams x = ([], x)--getLams (Lam b) = getLams b-getLams x = x--getGEnv f = do- (exs, src) <- ask- gets (\ge -> EGlobal src ge mempty) >>= f-inferTerm msg tr f t = asks fst >>= \exs -> getGEnv $ \env -> let env' = f env in smartTrace exs $ \tr -> - fmap (recheck msg env' . replaceMetas (lamPi Hidden)) $ lift (lift $ inferN (if tr then traceLevel exs else 0) env' t)-inferType tr t = asks fst >>= \exs -> getGEnv $ \env -> fmap (fst . recheck "inferType" env . flip (,) TType . replaceMetas (Pi Hidden) . fmap fst) $ lift (lift $ inferN (if tr then traceLevel exs else 0) (CheckType_ (debugSI "inferType CheckType_") TType env) t)--addToEnv :: Monad m => SIName -> (Exp, Exp) -> ElabStmtM m ()-addToEnv (si, s) (x, t) = do--- maybe (pure ()) throwError_ $ ambiguityCheck s t -- TODO- exs <- asks fst- when (trLight exs) $ mtrace (s ++ " :: " ++ ppShow t)- v <- gets $ Map.lookup s- case v of- Nothing -> modify $ Map.insert s (closedExp x, closedExp t, si)- Just (_, _, si')- | sameSource si si' -> getGEnv $ \ge -> throwError $ "already defined " ++ s ++ " at " ++ showSI ge si ++ "\n and at " ++ showSI ge si'- | otherwise -> getGEnv $ \ge -> throwError $ "already defined " ++ s ++ " at " ++ showSI ge si ++ "\n and at " ++ showSourcePosSI si'--downTo n m = map Var [n+m-1, n+m-2..n]--defined' = Map.keys--addF = asks fst >>= \exs -> gets $ addForalls exs . defined'--tellType te si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc True (t, TType)-tellStmtType si t = getGEnv $ \te -> tellType te si t----------------------------------------------------------------------------------- inference output--data PolyEnv = PolyEnv- { getPolyEnv :: GlobalEnv- , infos :: Infos- }--filterPolyEnv p pe = pe { getPolyEnv = Map.filterWithKey (\k _ -> p k) $ getPolyEnv pe }--joinPolyEnvs :: MonadError ErrorMsg m => Bool -> [PolyEnv] -> m PolyEnv-joinPolyEnvs _ = return . foldr mappend' mempty' -- todo- where- mempty' = PolyEnv mempty mempty- PolyEnv a b `mappend'` PolyEnv a' b' = PolyEnv (a `mappend` a') (b `mappend` b')---------------------------------------------------------------------------------- pretty print--- todo: do this via conversion to SExp--instance PShow Exp where- pShowPrec _ = showDoc_ . mkDoc False--instance PShow (CEnv Exp) where- pShowPrec _ = showDoc_ . mkDoc False--instance PShow Env where- pShowPrec _ e = showDoc_ $ envDoc e $ pure $ shAtom $ underlined "<<HERE>>"--showEnvExp :: Env -> ExpType -> String-showEnvExp e c = showDoc $ envDoc e $ epar <$> mkDoc False c--showEnvSExp :: Up a => Env -> SExp' a -> String-showEnvSExp e c = showDoc $ envDoc e $ epar <$> sExpDoc c--showEnvSExpType :: Up a => Env -> SExp' a -> Exp -> String-showEnvSExpType e c t = showDoc $ envDoc e $ epar <$> (shAnn "::" False <$> sExpDoc c <**> mkDoc False (t, TType))- where- infixl 4 <**>- (<**>) :: NameDB (a -> b) -> NameDB a -> NameDB b- a <**> b = get >>= \s -> lift $ evalStateT a s <*> evalStateT b s--{--expToSExp :: Exp -> SExp-expToSExp = \case- PMLabel x _ -> expToSExp x- FixLabel _ x -> expToSExp x--- Var k -> shAtom <$> shVar k- App a b -> SApp Visible{-todo-} (expToSExp a) (expToSExp b)-{-- Lam h a b -> join $ shLam (used 0 b) (BLam h) <$> f a <*> pure (f b)- Bind h a b -> join $ shLam (used 0 b) h <$> f a <*> pure (f b)- Cstr a b -> shCstr <$> f a <*> f b- MT s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs- CaseFun s xs -> foldl (shApp Visible) (shAtom $ show s) <$> mapM f xs- TyCaseFun s xs -> foldl (shApp Visible) (shAtom $ show s) <$> mapM f xs- ConN s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs- TyConN s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs--- TType -> pure $ shAtom "Type"- ELit l -> pure $ shAtom $ show l- Assign i x e -> shLet i (f x) (f e)- LabelEnd x -> shApp Visible (shAtom "labend") <$> f x--}-nameSExp :: SExp -> NameDB SExp-nameSExp = \case- SGlobal s -> pure $ SGlobal s- SApp h a b -> SApp h <$> nameSExp a <*> nameSExp b- SBind h a b -> newName >>= \n -> SBind h <$> nameSExp a <*> local (n:) (nameSExp b)- SLet a b -> newName >>= \n -> SLet <$> nameSExp a <*> local (n:) (nameSExp b)- STyped_ x (e, _) -> nameSExp $ expToSExp e -- todo: mark boundary- SVar i -> SGlobal <$> shVar i--}-envDoc :: Env -> Doc -> Doc-envDoc x m = case x of- EGlobal{} -> m- EBind1 _ h ts b -> envDoc ts $ join $ shLam (used 0 b) h <$> m <*> pure (sExpDoc b)- EBind2 h a ts -> envDoc ts $ join $ shLam True h <$> mkDoc ts' (a, TType) <*> pure m- EApp1 _ h ts b -> envDoc ts $ shApp h <$> m <*> sExpDoc b- EApp2 _ h (Lam (Var 0), Pi Visible TType _) ts -> envDoc ts $ shApp h (shAtom "tyType") <$> m- EApp2 _ h a ts -> envDoc ts $ shApp h <$> mkDoc ts' a <*> m- ELet1 _ ts b -> envDoc ts $ shLet_ m (sExpDoc b)- ELet2 _ x ts -> envDoc ts $ shLet_ (mkDoc ts' x) m- EAssign i x ts -> envDoc ts $ shLet i (mkDoc ts' x) m- CheckType t ts -> envDoc ts $ shAnn ":" False <$> m <*> mkDoc ts' (t, TType)--- CheckSame t ts -> envDoc ts $ shCstr <$> m <*> mkDoc ts' t- CheckAppType si h t te b -> envDoc (EApp1 si h (CheckType_ (sourceInfo b) t te) b) m- ELabelEnd ts -> envDoc ts $ shApp Visible (shAtom "labEnd") <$> m- where- ts' = False--class MkDoc a where- mkDoc :: Bool -> a -> Doc--instance MkDoc ExpType where- mkDoc ts e = mkDoc ts $ fst e--instance MkDoc Exp where- mkDoc ts e = fmap inGreen <$> f e- where- f = \case- FixLabel _ x -> f x- Neut x -> mkDoc ts x--- Lam h a b -> join $ shLam (used 0 b) (BLam h) <$> f a <*> pure (f b)- Lam b -> join $ shLam True (BLam Visible) <$> f TType{-todo-} <*> pure (f b)- Pi h a b -> join $ shLam (used 0 b) (BPi h) <$> f a <*> pure (f b)- ENat n -> pure $ shAtom $ show n- Con s _ xs -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM f xs- TyConN s xs -> foldl (shApp Visible) (shAtom_ s) <$> mapM f xs- TType -> pure $ shAtom "Type"- ELit l -> pure $ shAtom $ show l- LabelEnd_ k x -> shApp Visible (shAtom $ "labend" ++ show k) <$> f x-- shAtom_ = shAtom . if ts then switchTick else id--instance MkDoc Neutral where- mkDoc ts e = fmap inGreen <$> f e- where- g = mkDoc ts- f = \case- PMLabel_ s i xs _ -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g xs- Var_ k -> shAtom <$> shVar k- App_ a b -> shApp Visible <$> g a <*> g b- CstrT' TType a b -> shCstr <$> g a <*> g b- Fun_ s xs -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g xs- CaseFun_ s xs n -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g (xs ++ [Neut n])- TyCaseFun_ s [m, t, f] n -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g [m, t, Neut n, f]-- shAtom_ = shAtom . if ts then switchTick else id--instance MkDoc (CEnv Exp) where- mkDoc ts e = fmap inGreen <$> f e- where- f :: CEnv Exp -> Doc- f = \case- MEnd a -> mkDoc ts a- Meta a b -> join $ shLam True BMeta <$> mkDoc ts a <*> pure (f b)- Assign i (x, _) e -> shLet i (mkDoc ts x) (f e)---------------------------------------------------------------------------------- main--smartTrace :: MonadError String m => Extensions -> (Bool -> m a) -> m a-smartTrace exs f | traceLevel exs >= 2 = f True-smartTrace exs f | traceLevel exs == 0 = f False-smartTrace exs f = catchError (f False) $ \err ->- trace_ (unlines- [ "---------------------------------"- , err- , "try again with trace"- , "---------------------------------"- ]) $ f True--type TraceLevel = Int-traceLevel exs = if TraceTypeCheck `elem` exs then 1 else 0 :: TraceLevel -- 0: no trace-tr = False --traceLevel >= 2-trLight exs = traceLevel exs >= 1--inference_ :: PolyEnv -> Module -> ErrorT (WriterT Infos Identity) PolyEnv-inference_ (PolyEnv pe is) m = ff $ runWriter $ runExceptT $ mdo- let (x, dns) = definitions m ds- ds = mkDesugarInfo defs `joinDesugarInfo` extractDesugarInfo pe- defs <- either (throwError . ErrorMsg) return x- mapM_ (maybe (return ()) (throwErrorTCM . text)) dns- mapExceptT (fmap $ ErrorMsg +++ snd) . flip runStateT (initEnv <> pe) . flip runReaderT (extensions m, sourceCode m) . mapM_ (handleStmt defs) $ sortDefs ds defs- where- ff (Left e, is) = throwError e- ff (Right ge, is) = do- tell is- return $ PolyEnv ge is-+ ( Binder (..), SName, Lit(..), Visibility(..)+ , Exp (..), Neutral (..), ExpType, GlobalEnv+ , pattern Var, pattern CaseFun, pattern TyCaseFun, pattern App_, app_+ , pattern Con, pattern TyCon, pattern Pi, pattern Lam, pattern Fun, pattern ELit, pattern Func, pattern LabelEnd, pattern FL, pattern UFL, unFunc_+ , outputType, boolType, trueExp+ , down, Subst (..), free, subst+ , initEnv, Env(..), pattern EBind2+ , SI(..), Range(..) -- todo: remove+ , Info(..), Infos, listAllInfos, listTypeInfos, listTraceInfos+ , inference, IM+ , nType, conType, neutType, neutType', appTy, mkConPars, makeCaseFunPars, makeCaseFunPars'+ , MaxDB, unfixlabel+ , ErrorMsg, showError, errorRange+ , FName (..)+ ) where++import Data.Monoid+import Data.Char+import Data.Maybe+import Data.List+import qualified Data.Set as Set+import qualified Data.Map as Map++import Control.Monad.Except+import Control.Monad.Reader+import Control.Monad.Writer+import Control.Monad.State+import Control.Arrow hiding ((<+>))+import Control.DeepSeq++import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)+import LambdaCube.Compiler.Lexer+import LambdaCube.Compiler.Parser++-------------------------------------------------------------------------------- core expression representation++data Exp+ = TType+ | ELit_ Lit+ | Con_ !MaxDB ConName !Int{-number of ereased arguments applied-} [Exp]+ | TyCon_ !MaxDB TyConName [Exp]+ | Pi_ !MaxDB Visibility Exp Exp+ | Lam_ !MaxDB Exp+ | Neut Neutral+ deriving (Show)++pattern ELit a <- (unfixlabel -> ELit_ a) where ELit = ELit_++data Neutral+ = Fun_ !MaxDB FunName [Exp]{-local vars-} !Int{-number of missing parameters-} [Exp]{-given parameters, reversed-} Neutral{-unfolded expression-}{-not neut?-}+ | CaseFun__ !MaxDB CaseFunName [Exp] Neutral+ | TyCaseFun__ !MaxDB TyCaseFunName [Exp] Neutral+ | App__ !MaxDB Neutral Exp+ | Var_ !Int -- De Bruijn variable+ | LabelEnd_ Exp -- not neut?+ | Delta (SData ([Exp] -> Exp)) -- not neut?+ deriving (Show)++data ConName = ConName FName Int{-ordinal number, e.g. Zero:0, Succ:1-} Type++data TyConName = TyConName FName Int{-num of indices-} Type [(ConName, Type)]{-constructors-} CaseFunName++data FunName = FunName FName (Maybe Exp) Type++data CaseFunName = CaseFunName FName Type Int{-num of parameters-}++data TyCaseFunName = TyCaseFunName FName Type++type Type = Exp+type ExpType = (Exp, Type)+type SExp2 = SExp' ExpType++instance Show ConName where show (ConName n _ _) = show n+instance Eq ConName where ConName _ n _ == ConName _ n' _ = n == n'+instance Show TyConName where show (TyConName n _ _ _ _) = show n+instance Eq TyConName where TyConName n _ _ _ _ == TyConName n' _ _ _ _ = n == n'+instance Show FunName where show (FunName n _ _) = show n+instance Eq FunName where FunName n _ _ == FunName n' _ _ = n == n'+instance Show CaseFunName where show (CaseFunName n _ _) = CaseName $ show n+instance Eq CaseFunName where CaseFunName n _ _ == CaseFunName n' _ _ = n == n'+instance Show TyCaseFunName where show (TyCaseFunName n _) = MatchName $ show n+instance Eq TyCaseFunName where TyCaseFunName n _ == TyCaseFunName n' _ = n == n'++data FName+ = CFName !Int (SData String)+ | FVecScalar+ | FEqCT | FT2 | Fcoe | FparEval | Ft2C | FprimFix+ | FUnit+ | FInt+ | FWord+ | FNat+ | FBool+ | FFloat+ | FString+ | FChar+ | FOrdering+ | FVecS+ | FEmpty+ | FHList+ | FEq+ | FOrd+ | FNum+ | FSigned+ | FComponent+ | FIntegral+ | FFloating+ | FOutput+ | FType+ | FHCons+ | FHNil+ | FZero+ | FSucc+ | FFalse+ | FTrue+ | FLT+ | FGT+ | FEQ+ | FTT+ | FNil+ | FCons+ | FSplit+ deriving (Eq, Ord)++-- todo: use module indentifier instead of hash+cFName mod i (RangeSI (Range l _), s) = fromMaybe (CFName n $ SData s) $ lookup s fntable+ where+ n = hash (sourceName l) * 2^32 + sourceLine l * 2^16 + sourceColumn l * 2^3 -- + i+ hash = foldr (\c x -> ord c + x*2) 0++fntable =+ [ (,) "'VecScalar" FVecScalar+ , (,) "'EqCT" FEqCT+ , (,) "'T2" FT2+ , (,) "coe" Fcoe+ , (,) "parEval" FparEval+ , (,) "t2C" Ft2C+ , (,) "primFix" FprimFix+ , (,) "'Unit" FUnit+ , (,) "'Int" FInt+ , (,) "'Word" FWord+ , (,) "'Nat" FNat+ , (,) "'Bool" FBool+ , (,) "'Float" FFloat+ , (,) "'String" FString+ , (,) "'Char" FChar+ , (,) "'Ordering" FOrdering+ , (,) "'VecS" FVecS+ , (,) "'Empty" FEmpty+ , (,) "'HList" FHList+ , (,) "'Eq" FEq+ , (,) "'Ord" FOrd+ , (,) "'Num" FNum+ , (,) "'Signed" FSigned+ , (,) "'Component" FComponent+ , (,) "'Integral" FIntegral+ , (,) "'Floating" FFloating+ , (,) "'Output" FOutput+ , (,) "'Type" FType+ , (,) "HCons" FHCons+ , (,) "HNil" FHNil+ , (,) "Zero" FZero+ , (,) "Succ" FSucc+ , (,) "False" FFalse+ , (,) "True" FTrue+ , (,) "LT" FLT+ , (,) "GT" FGT+ , (,) "EQ" FEQ+ , (,) "TT" FTT+ , (,) "Nil" FNil+ , (,) "Cons" FCons+ , (,) "'Split" FSplit+ ]++instance Show FName where+ show (CFName _ (SData s)) = s+ show s = fromMaybe (error "show") $ lookup s $ map (\(a, b) -> (b, a)) fntable++-------------------------------------------------------------------------------- auxiliary functions and patterns++infixl 2 `App`, `app_`+infixr 1 :~>++pattern NoLE <- (isNoLabelEnd -> True)++isNoLabelEnd (LabelEnd_ _) = False+isNoLabelEnd _ = True++pattern Fun' f vs i xs n <- Fun_ _ f vs i xs n where Fun' f vs i xs n = Fun_ (foldMap maxDB_ vs <> foldMap maxDB_ xs {- <> iterateN i lowerDB (maxDB_ n)-}) f vs i xs n+pattern Fun f i xs n = Fun' f [] i xs n+pattern UTFun a t b <- (unfixlabel -> Neut (Fun (FunName a _ t) _ (reverse -> b) NoLE))+pattern UFunN a b <- UTFun a _ b+pattern DFun_ fn xs <- Fun fn 0 (reverse -> xs) (Delta _) where+ DFun_ fn@(FunName n _ _) xs = Fun fn 0 (reverse xs) d where+ d = Delta $ SData $ getFunDef n $ \xs -> Neut $ Fun fn 0 (reverse xs) d+pattern TFun' a t b = DFun_ (FunName a Nothing t) b+pattern TFun a t b = Neut (TFun' a t b)++pattern CaseFun_ a b c <- CaseFun__ _ a b c where CaseFun_ a b c = CaseFun__ (maxDB_ c <> foldMap maxDB_ b) a b c+pattern TyCaseFun_ a b c <- TyCaseFun__ _ a b c where TyCaseFun_ a b c = TyCaseFun__ (foldMap maxDB_ b <> maxDB_ c) a b c+pattern App_ a b <- App__ _ a b where App_ a b = App__ (maxDB_ a <> maxDB_ b) a b+pattern CaseFun a b c = Neut (CaseFun_ a b c)+pattern TyCaseFun a b c = Neut (TyCaseFun_ a b c)+pattern App a b <- Neut (App_ (Neut -> a) b)+pattern Var a = Neut (Var_ a)++conParams (conTypeName -> TyConName _ _ _ _ (CaseFunName _ _ pars)) = pars+mkConPars n (snd . getParams . unfixlabel -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) = take (min n pars) xs+--mkConPars 0 TType = [] -- ?+mkConPars n x@Neut{} = error $ "mkConPars!: " ++ ppShow x+mkConPars n x = error $ "mkConPars: " ++ ppShow (n, x)++makeCaseFunPars te n = case neutType te n of+ (unfixlabel -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) -> take pars xs+ x -> error $ "makeCaseFunPars: " ++ ppShow x++makeCaseFunPars' te n = case neutType' te n of+ (unfixlabel -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) -> take pars xs++pattern Closed :: () => Up a => a -> a+pattern Closed a <- a where Closed a = closedExp a++pattern Con x n y <- Con_ _ x n y where Con x n y = Con_ (foldMap maxDB_ y) x n y+pattern ConN s a <- Con (ConName s _ _) _ a+pattern ConN' s a <- Con (ConName _ s _) _ a+tCon s i t a = Con (ConName s i t) 0 a+tCon_ k s i t a = Con (ConName s i t) k a+pattern TyCon x y <- TyCon_ _ x y where TyCon x y = TyCon_ (foldMap maxDB_ y) x y+pattern Lam y <- Lam_ _ y where Lam y = Lam_ (lowerDB (maxDB_ y)) y+pattern Pi v x y <- Pi_ _ v x y where Pi v x y = Pi_ (maxDB_ x <> lowerDB (maxDB_ y)) v x y+pattern TyConN s a <- TyCon (TyConName s _ _ _ _) a+pattern TTyCon s t a <- TyCon (TyConName s _ t _ _) a+tTyCon s t a cs = TyCon (TyConName s (error "todo: inum") t (map ((,) (error "tTyCon")) cs) $ CaseFunName (error "TTyCon-A") (error "TTyCon-B") $ length a) a+pattern TTyCon0 s <- (unfixlabel -> TyCon (TyConName s _ TType _ _) [])+tTyCon0 s cs = Closed $ TyCon (TyConName s 0 TType (map ((,) (error "tTyCon0")) cs) $ CaseFunName (error "TTyCon0-A") (error "TTyCon0-B") 0) []+pattern a :~> b = Pi Visible a b++pattern Unit <- TTyCon0 FUnit where Unit = tTyCon0 FUnit [Unit]+pattern TInt <- TTyCon0 FInt where TInt = tTyCon0 FInt $ error "cs 1"+pattern TNat <- TTyCon0 FNat where TNat = tTyCon0 FNat $ error "cs 3"+pattern TBool <- TTyCon0 FBool where TBool = tTyCon0 FBool $ error "cs 4"+pattern TFloat <- TTyCon0 FFloat where TFloat = tTyCon0 FFloat $ error "cs 5"+pattern TString <- TTyCon0 FString where TString = tTyCon0 FString $ error "cs 6"+pattern TChar <- TTyCon0 FChar where TChar = tTyCon0 FChar $ error "cs 7"+pattern TOrdering <- TTyCon0 FOrdering where TOrdering = tTyCon0 FOrdering $ error "cs 8"+pattern TVec a b <- TyConN FVecS {-(TType :~> TNat :~> TType)-} [b, a]++pattern Empty s <- TyCon (TyConName FEmpty _ _ _ _) [EString s] where+ Empty s = TyCon (TyConName FEmpty (error "todo: inum2_") (TString :~> TType) (error "todo: tcn cons 3_") $ error "Empty") [EString s]++pattern TT <- ConN' _ _ where TT = Closed (tCon FTT 0 Unit [])+pattern Zero <- ConN FZero _ where Zero = Closed (tCon FZero 0 TNat [])+pattern Succ n <- ConN FSucc (n:_) where Succ n = tCon FSucc 1 (TNat :~> TNat) [n]++pattern CstrT t a b = Neut (CstrT' t a b)+pattern CstrT' t a b = TFun' FEqCT (TType :~> Var 0 :~> Var 1 :~> TType) [t, a, b]+pattern Coe a b w x = TFun Fcoe (TType :~> TType :~> CstrT TType (Var 1) (Var 0) :~> Var 2 :~> Var 2) [a,b,w,x]+pattern ParEval t a b = TFun FparEval (TType :~> Var 0 :~> Var 1 :~> Var 2) [t, a, b]+pattern T2 a b = TFun FT2 (TType :~> TType :~> TType) [a, b]+pattern CSplit a b c <- UFunN FSplit [a, b, c]++pattern EInt a = ELit (LInt a)+pattern EFloat a = ELit (LFloat a)+pattern EChar a = ELit (LChar a)+pattern EString a = ELit (LString a)+pattern EBool a <- (getEBool -> Just a) where EBool = mkBool+pattern ENat n <- (fromNatE -> Just n) where ENat = toNatE+pattern ENat' n <- (fromNatE' -> Just n)++toNatE :: Int -> Exp+toNatE 0 = Zero+toNatE n | n > 0 = Closed (Succ (toNatE (n - 1)))++fromNatE :: Exp -> Maybe Int+fromNatE (unfixlabel -> ConN' 0 _) = Just 0+fromNatE (unfixlabel -> ConN' 1 [n]) = (1 +) <$> fromNatE n+fromNatE _ = Nothing++fromNatE' :: Exp -> Maybe Int+fromNatE' (unfixlabel -> Zero) = Just 0+fromNatE' (unfixlabel -> Succ n) = (1 +) <$> fromNatE' n+fromNatE' _ = Nothing++mkBool False = Closed $ tCon FFalse 0 TBool []+mkBool True = Closed $ tCon FTrue 1 TBool []++getEBool (unfixlabel -> ConN' 0 _) = Just False+getEBool (unfixlabel -> ConN' 1 _) = Just True+getEBool _ = Nothing++mkOrdering x = Closed $ case x of+ LT -> tCon FLT 0 TOrdering []+ EQ -> tCon FEQ 1 TOrdering []+ GT -> tCon FGT 2 TOrdering []++conTypeName :: ConName -> TyConName+conTypeName (ConName _ _ t) = case snd $ getParams t of TyCon n _ -> n++outputType = tTyCon0 FOutput $ error "cs 9"+boolType = TBool+trueExp = EBool True++-------------------------------------------------------------------------------- label handling++pattern LabelEnd x = Neut (LabelEnd_ x)++--pmLabel' :: FunName -> [Exp] -> Int -> [Exp] -> Exp -> Exp+pmLabel' _ (FunName _ _ _) _ 0 as (Neut (Delta (SData f))) = f $ reverse as+pmLabel' md f vs i xs (unfixlabel -> Neut y) = Neut $ Fun_ md f vs i xs y+pmLabel' _ f _ i xs y = error $ "pmLabel: " ++ show (f, i, length xs, y)++pmLabel :: FunName -> [Exp] -> Int -> [Exp] -> Exp -> Exp+pmLabel f vs i xs e = pmLabel' (foldMap maxDB_ vs <> foldMap maxDB_ xs) f vs (i + numLams e) xs (Neut $ dropLams e)++dropLams (unfixlabel -> Lam x) = dropLams x+dropLams (unfixlabel -> Neut x) = x++numLams (unfixlabel -> Lam x) = 1 + numLams x+numLams x = 0++pattern FL' y <- Fun' f _ 0 xs (LabelEnd_ y)+pattern FL y <- Neut (FL' y)++pattern Func n def ty xs <- (mkFunc -> Just (n, def, ty, xs))++mkFunc (Neut (Fun (FunName n (Just def) ty) 0 xs LabelEnd_{})) | Just def' <- removeLams (length xs) def = Just (n, def', ty, xs)+mkFunc _ = Nothing++removeLams 0 (LabelEnd x) = Just x+removeLams n (Lam x) | n > 0 = Lam <$> removeLams (n-1) x+removeLams _ _ = Nothing++pattern UFL y <- (unFunc -> Just y)++unFunc (Neut (Fun' (FunName _ (Just def) _) _ n xs y)) = Just $ iterateN n Lam $ Neut y+unFunc _ = Nothing++unFunc_ (Neut (Fun' _ _ n xs y)) = Just $ iterateN n Lam $ Neut y+unFunc_ _ = Nothing++unfixlabel (FL y) = unfixlabel y+unfixlabel a = a++-------------------------------------------------------------------------------- low-level toolbox++class Subst b a where+ subst_ :: Int -> MaxDB -> b -> a -> a++subst i x a = subst_ i (maxDB_ x) x a++down :: (Subst Exp a, Up a{-used-}) => Int -> a -> Maybe a+down t x | used t x = Nothing+ | otherwise = Just $ subst_ t mempty (error "impossible: down" :: Exp) x++instance Eq Exp where+ FL a == a' = a == a'+ a == FL a' = a == a'+ Lam a == Lam a' = a == a'+ Pi a b c == Pi a' b' c' = (a, b, c) == (a', b', c')+ Con a n b == Con a' n' b' = (a, n, b) == (a', n', b')+ TyCon a b == TyCon a' b' = (a, b) == (a', b')+ TType == TType = True+ ELit l == ELit l' = l == l'+ Neut a == Neut a' = a == a'+ _ == _ = False++instance Eq Neutral where+ Fun' f vs i a _ == Fun' f' vs' i' a' _ = (f, vs, i, a) == (f', vs', i', a')+ FL' a == a' = a == Neut a'+ a == FL' a' = Neut a == a'+ LabelEnd_ a == LabelEnd_ a' = a == a'+ CaseFun_ a b c == CaseFun_ a' b' c' = (a, b, c) == (a', b', c')+ TyCaseFun_ a b c == TyCaseFun_ a' b' c' = (a, b, c) == (a', b', c')+ App_ a b == App_ a' b' = (a, b) == (a', b')+ Var_ a == Var_ a' = a == a'+ _ == _ = False++free x | cmpDB 0 x = mempty+free x = fold (\i k -> Set.fromList [k - i | k >= i]) 0 x++instance Up Exp where+ up_ 0 = \_ e -> e+ up_ n = f where+ f i e | cmpDB i e = e+ f i e = case e of+ Lam_ md b -> Lam_ (upDB n md) (f (i+1) b)+ Pi_ md h a b -> Pi_ (upDB n md) h (f i a) (f (i+1) b)+ Con_ md s pn as -> Con_ (upDB n md) s pn $ map (f i) as+ TyCon_ md s as -> TyCon_ (upDB n md) s $ map (f i) as+ Neut x -> Neut $ up_ n i x++ used i e+ | cmpDB i e = False+ | otherwise = ((getAny .) . fold ((Any .) . (==))) i e++ fold f i = \case+ Lam b -> fold f (i+1) b+ Pi _ a b -> fold f i a <> fold f (i+1) b+ Con _ _ as -> foldMap (fold f i) as+ TyCon _ as -> foldMap (fold f i) as+ TType -> mempty+ ELit{} -> mempty+ Neut x -> fold f i x++ maxDB_ = \case+ Lam_ c _ -> c+ Pi_ c _ _ _ -> c+ Con_ c _ _ _ -> c+ TyCon_ c _ _ -> c++ TType -> mempty+ ELit{} -> mempty+ Neut x -> maxDB_ x++ closedExp = \case+ Lam_ _ c -> Lam_ mempty c+ Pi_ _ a b c -> Pi_ mempty a (closedExp b) c+ Con_ _ a b c -> Con_ mempty a b (closedExp <$> c)+ TyCon_ _ a b -> TyCon_ mempty a (closedExp <$> b)+ e@TType{} -> e+ e@ELit{} -> e+ Neut a -> Neut $ closedExp a++instance Subst Exp Exp where+ subst_ i0 dx x = f i0+ where+ f i (Neut n) = substNeut n+ where+ substNeut e | cmpDB i e = Neut e+ substNeut e = case e of+ Var_ k -> case compare k i of GT -> Var $ k - 1; LT -> Var k; EQ -> up (i - i0) x+ CaseFun_ s as n -> evalCaseFun s (f i <$> as) (substNeut n)+ TyCaseFun_ s as n -> evalTyCaseFun s (f i <$> as) (substNeut n)+ App_ a b -> app_ (substNeut a) (f i b)+ Fun_ md fn vs c xs v -> pmLabel' (md <> upDB i dx) fn (f i <$> vs) c (f i <$> xs) $ f (i + c) $ Neut v+ LabelEnd_ a -> LabelEnd $ f i a+ d@Delta{} -> Neut d+ f i e | cmpDB i e = e+ f i e = case e of+ Lam_ md b -> Lam_ (md <> upDB i dx) (f (i+1) b)+ Con_ md s n as -> Con_ (md <> upDB i dx) s n $ f i <$> as+ Pi_ md h a b -> Pi_ (md <> upDB i dx) h (f i a) (f (i+1) b)+ TyCon_ md s as -> TyCon_ (md <> upDB i dx) s $ f i <$> as++instance Up Neutral where++ up_ 0 = \_ e -> e+ up_ n = f where+ f i e | cmpDB i e = e+ f i e = case e of+ Var_ k -> Var_ $ if k >= i then k+n else k+ CaseFun__ md s as ne -> CaseFun__ (upDB n md) s (up_ n i <$> as) (up_ n i ne)+ TyCaseFun__ md s as ne -> TyCaseFun__ (upDB n md) s (up_ n i <$> as) (up_ n i ne)+ App__ md a b -> App__ (upDB n md) (up_ n i a) (up_ n i b)+ Fun_ md fn vs c x y -> Fun_ (upDB n md) fn (up_ n i <$> vs) c (up_ n i <$> x) $ up_ n (i + c) y+ LabelEnd_ x -> LabelEnd_ $ up_ n i x+ d@Delta{} -> d++ used i e+ | cmpDB i e = False+ | otherwise = ((getAny .) . fold ((Any .) . (==))) i e++ fold f i = \case+ Var_ k -> f i k+ CaseFun_ _ as n -> foldMap (fold f i) as <> fold f i n+ TyCaseFun_ _ as n -> foldMap (fold f i) as <> fold f i n+ App_ a b -> fold f i a <> fold f i b+ Fun' _ vs j x d -> foldMap (fold f i) vs <> foldMap (fold f i) x -- <> fold f (i+j) d+ LabelEnd_ x -> fold f i x+ Delta{} -> mempty++ maxDB_ = \case+ Var_ k -> varDB k+ CaseFun__ c _ _ _ -> c+ TyCaseFun__ c _ _ _ -> c+ App__ c a b -> c+ Fun_ c _ _ _ _ _ -> c+ LabelEnd_ x -> maxDB_ x+ Delta{} -> mempty++ closedExp = \case+ x@Var_{} -> error "impossible"+ CaseFun__ _ a as n -> CaseFun__ mempty a (closedExp <$> as) (closedExp n)+ TyCaseFun__ _ a as n -> TyCaseFun__ mempty a (closedExp <$> as) (closedExp n)+ App__ _ a b -> App__ mempty (closedExp a) (closedExp b)+ Fun_ _ f l i x y -> Fun_ mempty f l i (closedExp <$> x) y+ LabelEnd_ a -> LabelEnd_ (closedExp a)+ d@Delta{} -> d++instance (Subst x a, Subst x b) => Subst x (a, b) where+ subst_ i dx x (a, b) = (subst_ i dx x a, subst_ i dx x b)++varType' :: Int -> [Exp] -> Exp+varType' i vs = vs !! i++varType :: String -> Int -> Env -> (Binder, Exp)+varType err n_ env = f n_ env where+ f n (EAssign i (x, _) es) = second (subst i x) $ f (if n < i then n else n+1) es+ f n (EBind2 b t es) = if n == 0 then (b, up 1 t) else second (up 1) $ f (n-1) es+ f n (ELet2 _ (x, t) es) = if n == 0 then (BLam Visible{-??-}, up 1 t) else second (up 1) $ f (n-1) es+ f n e = either (error $ "varType: " ++ err ++ "\n" ++ show n_ ++ "\n" ++ ppShow env) (f n) $ parent e++-------------------------------------------------------------------------------- reduction+evalCaseFun a ps (Con n@(ConName _ i _) _ vs)+ | i /= (-1) = foldl app_ (ps !!! (i + 1)) vs+ | otherwise = error "evcf"+ where+ xs !!! i | i >= length xs = error $ "!!! " ++ show a ++ " " ++ show i ++ " " ++ show n ++ "\n" ++ ppShow ps+ xs !!! i = xs !! i+evalCaseFun a b (FL c) = evalCaseFun a b c+evalCaseFun a b (Neut c) = CaseFun a b c+evalCaseFun a b x = error $ "evalCaseFun: " ++ show (a, x)++evalTyCaseFun a b (FL c) = evalTyCaseFun a b c+evalTyCaseFun a b (Neut c) = TyCaseFun a b c+evalTyCaseFun (TyCaseFunName FType ty) (_: t: f: _) TType = t+evalTyCaseFun (TyCaseFunName n ty) (_: t: f: _) (TyCon (TyConName n' _ _ _ _) vs) | n == n' = foldl app_ t vs+--evalTyCaseFun (TyCaseFunName n ty) [_, t, f] (DFun (FunName n' _) vs) | n == n' = foldl app_ t vs -- hack+evalTyCaseFun (TyCaseFunName n ty) (_: t: f: _) _ = f++evalCoe a b (FL x) d = evalCoe a b x d+evalCoe a b TT d = d+evalCoe a b t d = Coe a b t d++{- todo: generate+ DFun n@(FunName "natElim" _) [a, z, s, Succ x] -> let -- todo: replace let with better abstraction+ sx = s `app_` x+ in sx `app_` eval (DFun n [a, z, s, x])+ MT "natElim" [_, z, s, Zero] -> z+ DFun na@(FunName "finElim" _) [m, z, s, n, ConN "FSucc" [i, x]] -> let six = s `app_` i `app_` x-- todo: replace let with better abstraction+ in six `app_` eval (DFun na [m, z, s, i, x])+ MT "finElim" [m, z, s, n, ConN "FZero" [i]] -> z `app_` i+-}++getFunDef s f = case s of+ FEqCT -> \case (t: a: b: _) -> cstr t a b+ FT2 -> \case (a: b: _) -> t2 a b+ Ft2C -> \case (a: b: _) -> t2C a b+ Fcoe -> \case (a: b: t: d: _) -> evalCoe a b t d+ FparEval -> \case (t: a: b: _) -> parEval t a b+ where+ parEval _ (LabelEnd x) _ = LabelEnd x+ parEval _ _ (LabelEnd x) = LabelEnd x+ parEval t a b = ParEval t a b+ CFName _ (SData s) -> case s of+ "unsafeCoerce" -> \case xs@(_: _: x@NonNeut: _) -> x; xs -> f xs+ "reflCstr" -> \case (a: _) -> TT++ "hlistNilCase" -> \case (_: x: (unfixlabel -> Con n@(ConName _ 0 _) _ _): _) -> x; xs -> f xs+ "hlistConsCase" -> \case (_: _: _: x: (unfixlabel -> Con n@(ConName _ 1 _) _ (_: _: a: b: _)): _) -> x `app_` a `app_` b; xs -> f xs++ -- general compiler primitives+ "primAddInt" -> \case (EInt i: EInt j: _) -> EInt (i + j); xs -> f xs+ "primSubInt" -> \case (EInt i: EInt j: _) -> EInt (i - j); xs -> f xs+ "primModInt" -> \case (EInt i: EInt j: _) -> EInt (i `mod` j); xs -> f xs+ "primSqrtFloat" -> \case (EFloat i: _) -> EFloat $ sqrt i; xs -> f xs+ "primRound" -> \case (EFloat i: _) -> EInt $ round i; xs -> f xs+ "primIntToFloat" -> \case (EInt i: _) -> EFloat $ fromIntegral i; xs -> f xs+ "primIntToNat" -> \case (EInt i: _) -> ENat $ fromIntegral i; xs -> f xs+ "primCompareInt" -> \case (EInt x: EInt y: _) -> mkOrdering $ x `compare` y; xs -> f xs+ "primCompareFloat" -> \case (EFloat x: EFloat y: _) -> mkOrdering $ x `compare` y; xs -> f xs+ "primCompareChar" -> \case (EChar x: EChar y: _) -> mkOrdering $ x `compare` y; xs -> f xs+ "primCompareString" -> \case (EString x: EString y: _) -> mkOrdering $ x `compare` y; xs -> f xs++ -- LambdaCube 3D specific primitives+ "PrimGreaterThan" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (>) t x y -> r; xs -> f xs+ "PrimGreaterThanEqual" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (>=) t x y -> r; xs -> f xs+ "PrimLessThan" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (<) t x y -> r; xs -> f xs+ "PrimLessThanEqual" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (<=) t x y -> r; xs -> f xs+ "PrimEqualV" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (==) t x y -> r; xs -> f xs+ "PrimNotEqualV" -> \case (t: _: _: _: _: _: _: x: y: _) | Just r <- twoOpBool (/=) t x y -> r; xs -> f xs+ "PrimEqual" -> \case (t: _: _: x: y: _) | Just r <- twoOpBool (==) t x y -> r; xs -> f xs+ "PrimNotEqual" -> \case (t: _: _: x: y: _) | Just r <- twoOpBool (/=) t x y -> r; xs -> f xs+ "PrimSubS" -> \case (_: _: _: _: x: y: _) | Just r <- twoOp (-) x y -> r; xs -> f xs+ "PrimSub" -> \case (_: _: x: y: _) | Just r <- twoOp (-) x y -> r; xs -> f xs+ "PrimAddS" -> \case (_: _: _: _: x: y: _) | Just r <- twoOp (+) x y -> r; xs -> f xs+ "PrimAdd" -> \case (_: _: x: y: _) | Just r <- twoOp (+) x y -> r; xs -> f xs+ "PrimMulS" -> \case (_: _: _: _: x: y: _) | Just r <- twoOp (*) x y -> r; xs -> f xs+ "PrimMul" -> \case (_: _: x: y: _) | Just r <- twoOp (*) x y -> r; xs -> f xs+ "PrimDivS" -> \case (_: _: _: _: _: x: y: _) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs+ "PrimDiv" -> \case (_: _: _: _: _: x: y: _) | Just r <- twoOp_ (/) div x y -> r; xs -> f xs+ "PrimModS" -> \case (_: _: _: _: _: x: y: _) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs+ "PrimMod" -> \case (_: _: _: _: _: x: y: _) | Just r <- twoOp_ modF mod x y -> r; xs -> f xs+ "PrimNeg" -> \case (_: x: _) | Just r <- oneOp negate x -> r; xs -> f xs+ "PrimAnd" -> \case (EBool x: EBool y: _) -> EBool (x && y); xs -> f xs+ "PrimOr" -> \case (EBool x: EBool y: _) -> EBool (x || y); xs -> f xs+ "PrimXor" -> \case (EBool x: EBool y: _) -> EBool (x /= y); xs -> f xs+ "PrimNot" -> \case (TNat: _: _: EBool x: _) -> EBool $ not x; xs -> f xs++ _ -> f++ _ -> f++cstr = f []+ where+ f z ty a a' = f_ z (unfixlabel ty) (unfixlabel a) (unfixlabel a')++ f_ _ _ a a' | a == a' = Unit+ f_ ns typ (LabelEnd a) (LabelEnd a') = f ns typ a a'+ f_ ns typ (Con a n xs) (Con a' n' xs') | a == a' && n == n' && length xs == length xs' = + ff ns (foldl appTy (conType typ a) $ mkConPars n typ) $ zip xs xs'+ f_ ns typ (TyCon a xs) (TyCon a' xs') | a == a' && length xs == length xs' = + ff ns (nType a) $ zip xs xs'+ f_ (_: ns) typ{-down?-} (down 0 -> Just a) (down 0 -> Just a') = f ns typ a a'+ f_ ns TType (Pi h a b) (Pi h' a' b') | h == h' = t2 (f ns TType a a') (f ((a, a'): ns) TType b b')++ f_ [] TType (UFunN FVecScalar [a, b]) (UFunN FVecScalar [a', b']) = t2 (f [] TNat a a') (f [] TType b b')+ f_ [] TType (UFunN FVecScalar [a, b]) (TVec a' b') = t2 (f [] TNat a a') (f [] TType b b')+ f_ [] TType (UFunN FVecScalar [a, b]) t@NonNeut = t2 (f [] TNat a (ENat 1)) (f [] TType b t)+ f_ [] TType (TVec a' b') (UFunN FVecScalar [a, b]) = t2 (f [] TNat a' a) (f [] TType b' b)+ f_ [] TType t@NonNeut (UFunN FVecScalar [a, b]) = t2 (f [] TNat a (ENat 1)) (f [] TType b t)++ f_ [] typ a@Neut{} a' = CstrT typ a a'+ f_ [] typ a a'@Neut{} = CstrT typ a a'+ f_ ns typ a a' = Empty $ unlines [ "can not unify", ppShow a, "with", ppShow a' ]++ ff _ _ [] = Unit+ ff ns tt@(Pi v t _) ((t1, t2'): ts) = t2 (f ns t t1 t2') $ ff ns (appTy tt t1) ts+ ff ns t zs = error $ "ff: " -- ++ show (a, n, length xs', length $ mkConPars n typ) ++ "\n" ++ ppShow (nType a) ++ "\n" ++ ppShow (foldl appTy (nType a) $ mkConPars n typ) ++ "\n" ++ ppShow (zip xs xs') ++ "\n" ++ ppShow zs ++ "\n" ++ ppShow t++pattern NonNeut <- (nonNeut -> True)++nonNeut FL{} = True+nonNeut Neut{} = False+nonNeut _ = True++t2C (unfixlabel -> TT) (unfixlabel -> TT) = TT+t2C a b = TFun Ft2C (Unit :~> Unit :~> Unit) [a, b]++t2 (unfixlabel -> Unit) a = a+t2 a (unfixlabel -> Unit) = a+t2 (unfixlabel -> Empty a) (unfixlabel -> Empty b) = Empty (a <> b)+t2 (unfixlabel -> Empty s) _ = Empty s+t2 _ (unfixlabel -> Empty s) = Empty s+t2 a b = T2 a b++oneOp :: (forall a . Num a => a -> a) -> Exp -> Maybe Exp+oneOp f = oneOp_ f f++oneOp_ f _ (EFloat x) = Just $ EFloat $ f x+oneOp_ _ f (EInt x) = Just $ EInt $ f x+oneOp_ _ _ _ = Nothing++twoOp :: (forall a . Num a => a -> a -> a) -> Exp -> Exp -> Maybe Exp+twoOp f = twoOp_ f f++twoOp_ f _ (EFloat x) (EFloat y) = Just $ EFloat $ f x y+twoOp_ _ f (EInt x) (EInt y) = Just $ EInt $ f x y+twoOp_ _ _ _ _ = Nothing++modF x y = x - fromIntegral (floor (x / y)) * y++twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Exp -> Maybe Exp+twoOpBool f t (EFloat x) (EFloat y) = Just $ EBool $ f x y+twoOpBool f t (EInt x) (EInt y) = Just $ EBool $ f x y+twoOpBool f t (EString x) (EString y) = Just $ EBool $ f x y+twoOpBool f t (EChar x) (EChar y) = Just $ EBool $ f x y+twoOpBool f TNat (ENat x) (ENat y) = Just $ EBool $ f x y+twoOpBool _ _ _ _ = Nothing++app_ :: Exp -> Exp -> Exp+app_ (Lam x) a = subst 0 a x+app_ (Con s n xs) a = if n < conParams s then Con s (n+1) xs else Con s n (xs ++ [a])+app_ (TyCon s xs) a = TyCon s (xs ++ [a])+app_ (Neut f) a = neutApp f a+ where+ neutApp (FL' x) a = app_ x a -- ???+ neutApp (Fun' f vs i xs e) a | i > 0 = pmLabel f vs (i-1) (a: xs) (subst (i-1) (up (i-1) a) $ Neut e)+ neutApp f a = Neut $ App_ f a++-------------------------------------------------------------------------------- constraints env++data CEnv a+ = MEnd a+ | Meta Exp (CEnv a)+ | Assign !Int ExpType (CEnv a) -- De Bruijn index decreasing assign reservedOp, only for metavariables (non-recursive)+ deriving (Show, Functor)++instance (Subst Exp a, Up a) => Up (CEnv a) where+ up_ n i = iterateN n $ up1_ i+ up1_ i = \case+ MEnd a -> MEnd $ up1_ i a+ Meta a b -> Meta (up1_ i a) (up1_ (i+1) b)+ Assign j a b -> handleLet i j $ \i' j' -> assign j' (up1_ i' a) (up1_ i' b)+ where+ handleLet i j f+ | i > j = f (i-1) j+ | i <= j = f i (j+1)++ used i a = error "used @(CEnv _)"++ fold _ _ _ = error "fold @(CEnv _)"++ maxDB_ _ = error "maxDB_ @(CEnv _)"++instance (Subst Exp a, Up a) => Subst Exp (CEnv a) where+ subst_ i dx x = \case+ MEnd a -> MEnd $ subst_ i dx x a+ Meta a b -> Meta (subst_ i dx x a) (subst_ (i+1) (upDB 1 dx) (up 1 x) b)+ Assign j a b+ | j > i, Just a' <- down i a -> assign (j-1) a' (subst i (subst (j-1) (fst a') x) b)+ | j > i, Just x' <- down (j-1) x -> assign (j-1) (subst i x' a) (subst i x' b)+ | j < i, Just a' <- down (i-1) a -> assign j a' (subst (i-1) (subst j (fst a') x) b)+ | j < i, Just x' <- down j x -> assign j (subst (i-1) x' a) (subst (i-1) x' b)+ | j == i -> Meta (cstr (snd a) x $ fst a) $ up1_ 0 b++--assign :: (Int -> Exp -> CEnv Exp -> a) -> (Int -> Exp -> CEnv Exp -> a) -> Int -> Exp -> CEnv Exp -> a+swapAssign _ clet i (Var j, t) b | i > j = clet j (Var (i-1), t) $ subst j (Var (i-1)) $ up1_ i b+swapAssign clet _ i a b = clet i a b++assign = swapAssign Assign Assign+++-------------------------------------------------------------------------------- environments++-- SExp + Exp zipper+data Env+ = EBind1 SI Binder Env SExp2 -- zoom into first parameter of SBind+ | EBind2_ SI Binder Type Env -- zoom into second parameter of SBind+ | EApp1 SI Visibility Env SExp2+ | EApp2 SI Visibility ExpType Env+ | ELet1 SIName Env SExp2+ | ELet2 SIName ExpType Env+ | EGlobal+ | ELabelEnd Env++ | EAssign Int ExpType Env+ | CheckType_ SI Type Env+ | CheckIType SExp2 Env+-- | CheckSame Exp Env+ | CheckAppType SI Visibility Type Env SExp2 --pattern CheckAppType _ h t te b = EApp1 _ h (CheckType t te) b+ deriving Show++pattern EBind2 b e env <- EBind2_ _ b e env where EBind2 b e env = EBind2_ (debugSI "6") b e env+pattern CheckType e env <- CheckType_ _ e env where CheckType e env = CheckType_ (debugSI "7") e env++parent = \case+ EAssign _ _ x -> Right x+ EBind2 _ _ x -> Right x+ EBind1 _ _ x _ -> Right x+ EApp1 _ _ x _ -> Right x+ EApp2 _ _ _ x -> Right x+ ELet1 _ x _ -> Right x+ ELet2 _ _ x -> Right x+ CheckType _ x -> Right x+ CheckIType _ x -> Right x+-- CheckSame _ x -> Right x+ CheckAppType _ _ _ x _ -> Right x+ ELabelEnd x -> Right x+ EGlobal -> Left ()++-------------------------------------------------------------------------------- simple typing++litType = \case+ LInt _ -> TInt+ LFloat _ -> TFloat+ LString _ -> TString+ LChar _ -> TChar++class NType a where nType :: a -> Type++instance NType FunName where nType (FunName _ _ t) = t+instance NType TyConName where nType (TyConName _ _ t _ _) = t+instance NType CaseFunName where nType (CaseFunName _ t _) = t+instance NType TyCaseFunName where nType (TyCaseFunName _ t) = t++conType (snd . getParams . unfixlabel -> TyCon (TyConName _ _ _ cs _) _) (ConName _ n t) = t --snd $ cs !! n++neutType te = \case+ App_ f x -> appTy (neutType te f) x+ Var_ i -> snd $ varType "C" i te+ CaseFun_ s ts n -> appTy (foldl appTy (nType s) $ makeCaseFunPars te n ++ ts) (Neut n)+ TyCaseFun_ s [m, t, f] n -> foldl appTy (nType s) [m, t, Neut n, f]+ Fun' s _ _ a _ -> foldlrev appTy (nType s) a++neutType' te = \case+ App_ f x -> appTy (neutType' te f) x+ Var_ i -> varType' i te+ CaseFun_ s ts n -> appTy (foldl appTy (nType s) $ makeCaseFunPars' te n ++ ts) (Neut n)+ TyCaseFun_ s [m, t, f] n -> foldl appTy (nType s) [m, t, Neut n, f]+ Fun' s _ _ a _ -> foldlrev appTy (nType s) a++mkExpTypes t [] = []+mkExpTypes t@(Pi _ a _) (x: xs) = (x, t): mkExpTypes (appTy t x) xs++appTy (Pi _ a b) x = subst 0 x b+appTy t x = error $ "appTy: " ++ show t++-------------------------------------------------------------------------------- error messages++data ErrorMsg+ = ErrorMsg String+ | ECantFind SName SI+ | ETypeError String SI+ | ERedefined SName SI SI++instance NFData ErrorMsg where+ rnf = \case+ ErrorMsg m -> rnf m+ ECantFind a b -> rnf (a, b)+ ETypeError a b -> rnf (a, b)+ ERedefined a b c -> rnf (a, b, c)++errorRange_ = \case+ ErrorMsg s -> []+ ECantFind s si -> [si]+ ETypeError msg si -> [si]+ ERedefined s si si' -> [si, si']++showError :: Map.Map FilePath String -> ErrorMsg -> String+showError srcs = \case+ ErrorMsg s -> s+ ECantFind s si -> "can't find: " ++ s ++ " in " ++ showSI srcs si+ ETypeError msg si -> "type error: " ++ msg ++ "\nin " ++ showSI srcs si ++ "\n"+ ERedefined s si si' -> "already defined " ++ s ++ " at " ++ showSI srcs si ++ "\n and at " ++ showSI srcs si'++instance Show ErrorMsg where+ show = showError mempty++-------------------------------------------------------------------------------- inference++-- inference monad+type IM m = ExceptT ErrorMsg (ReaderT (Extensions, GlobalEnv) (WriterT Infos m))++expAndType s (e, t, si) = (e, t)++-- todo: do only if NoTypeNamespace extension is not on+lookupName s@('\'':s') m = expAndType s <$> (Map.lookup s m `mplus` Map.lookup s' m)+lookupName s m = expAndType s <$> Map.lookup s m++getDef te si s = do+ nv <- asks snd+ maybe (throwError' $ ECantFind s si) return (lookupName s nv)++type ExpType' = CEnv ExpType++inferN :: forall m . Monad m => Env -> SExp2 -> IM m ExpType'+inferN e s = do+ b <- asks $ (TraceTypeCheck `elem`) . fst+ mapExceptT (mapReaderT $ mapWriterT $ fmap filt) $ inferN_ (if b then \s x m -> tell [ITrace s x] >> m else \_ _ m -> m) e s+ where+ filt (e@Right{}, is) = (e, filter f is)+ filt x = x++ f ITrace{} = False+ f _ = True++substTo i x = subst i x . up1_ (i+1)++inferN_ :: forall m . Monad m => (forall a . String -> String -> IM m a -> IM m a) -> Env -> SExp2 -> IM m ExpType'+inferN_ tellTrace = infer where++ infer :: Env -> SExp2 -> IM m ExpType'+ infer te exp = tellTrace "infer" (showEnvSExp te exp) $ (if debug then fmap (fmap{-todo-} $ recheck' "infer" te) else id) $ case exp of+ Parens x -> infer te x+ SAnn x t -> checkN (CheckIType x te) t TType+ SLabelEnd x -> infer (ELabelEnd te) x+ SVar (si, _) i -> focus_' te exp (Var i, snd $ varType "C2" i te)+ SLit si l -> focus_' te exp (ELit l, litType l)+ STyped si et -> focus_' te exp et+ SGlobal (si, s) -> focus_' te exp =<< getDef te si s+ SApp si h a b -> infer (EApp1 (si `validate` [sourceInfo a, sourceInfo b]) h te b) a+ SLet le a b -> infer (ELet1 le te b{-in-}) a{-let-} -- infer te SLamV b `SAppV` a)+ SBind si h _ a b -> infer ((if h /= BMeta then CheckType_ (sourceInfo exp) TType else id) $ EBind1 si h te $ (if isPi h then TyType else id) b) a++ checkN :: Env -> SExp2 -> Type -> IM m ExpType'+ checkN te x t = tellTrace "check" (showEnvSExpType te x t) $ checkN_ te x t++ checkN_ te (Parens e) t = checkN_ te e t+ checkN_ te e t+ | x@(SGlobal (si, MatchName n)) `SAppV` SLamV (Wildcard _) `SAppV` a `SAppV` SVar siv v `SAppV` b <- e+ = infer te $ x `SAppV` SLam Visible SType (STyped mempty (subst (v+1) (Var 0) $ up 1 t, TType)) `SAppV` a `SAppV` SVar siv v `SAppV` b+ -- temporal hack+ | x@(SGlobal (si, CaseName "'Nat")) `SAppV` SLamV (Wildcard _) `SAppV` a `SAppV` b `SAppV` SVar siv v <- e+ = infer te $ x `SAppV` SLamV (STyped mempty (substTo (v+1) (Var 0) $ up 1 t, TType)) `SAppV` a `SAppV` b `SAppV` SVar siv v+ -- temporal hack+ | x@(SGlobal (si, CaseName "'VecS")) `SAppV` SLamV (SLamV (Wildcard _)) `SAppV` a `SAppV` b `SAppV` c `SAppV` SVar siv v <- e+ , TyConN FVecS [_, Var n'] <- snd $ varType "xx" v te+ = infer te $ x `SAppV` SLamV (SLamV (STyped mempty (substTo (n'+2) (Var 1) $ up 2 t, TType))) `SAppV` a `SAppV` b `SAppV` c `SAppV` SVar siv v++{-+ -- temporal hack+ | x@(SGlobal (si, "'HListCase")) `SAppV` SLamV (SLamV (Wildcard _)) `SAppV` a `SAppV` b `SAppV` SVar siv v <- e+ , TVec (Var n') _ <- snd $ varType "xx" v te+ = infer te $ x `SAppV` SLamV (SLamV (STyped mempty (subst (n'+2) (Var 1) $ up1_ (n'+3) $ up 2 t, TType))) `SAppV` a `SAppV` b `SAppV` SVar siv v+-}+ | SLabelEnd x <- e = checkN (ELabelEnd te) x t+ | SApp si h a b <- e = infer (CheckAppType si h t te b) a+ | SLam h a b <- e, Pi h' x y <- t, h == h' = do+ tellType e t+ let same = checkSame te a x+ if same then checkN (EBind2 (BLam h) x te) b y else error $ "checkSame:\n" ++ show a ++ "\nwith\n" ++ showEnvExp te (x, TType)+ | Pi Hidden a b <- t = do+ bb <- notHiddenLam e+ if bb then checkN (EBind2 (BLam Hidden) a te) (up1 e) b+ else infer (CheckType_ (sourceInfo e) t te) e+ | otherwise = infer (CheckType_ (sourceInfo e) t te) e+ where+ -- todo+ notHiddenLam = \case+ SLam Visible _ _ -> return True+ SGlobal (si,s) -> do+ nv <- asks snd+ case fromMaybe (error $ "infer: can't find: " ++ s) $ lookupName s nv of+ (Lam _, Pi Hidden _ _) -> return False+ _ -> return True+ _ -> return False+{-+ -- todo+ checkSame te (Wildcard _) a = return (te, True)+ checkSame te x y = do+ (ex, _) <- checkN te x TType+ return $ ex == y+-}+ checkSame te (Wildcard _) a = True+ checkSame te (SGlobal (_,"'Type")) TType = True+ checkSame te SType TType = True+ checkSame te (SBind _ BMeta _ SType (STyped _ (Var 0, _))) a = True+ checkSame te a b = error $ "checkSame: " ++ show (a, b)++ hArgs (Pi Hidden _ b) = 1 + hArgs b+ hArgs _ = 0++ focus_' env si eet = tellType si (snd eet) >> focus_ env eet++ focus_ :: Env -> ExpType -> IM m ExpType'+ focus_ env eet@(e, et) = tellTrace "focus" (showEnvExp env eet) $ (if debug then fmap (fmap{-todo-} $ recheck' "focus" env) else id) $ case env of+ ELabelEnd te -> focus_ te (LabelEnd e, et)+-- CheckSame x te -> focus_ (EBind2_ (debugSI "focus_ CheckSame") BMeta (cstr x e) te) $ up 1 eet+ CheckAppType si h t te b -- App1 h (CheckType t te) b+ | Pi h' x (down 0 -> Just y) <- et, h == h' -> case t of+ Pi Hidden t1 t2 | h == Visible -> focus_ (EApp1 si h (CheckType_ (sourceInfo b) t te) b) eet -- <<e>> b : {t1} -> {t2}+ _ -> focus_ (EBind2_ (sourceInfo b) BMeta (cstr TType t y) $ EApp1 si h te b) $ up 1 eet+ | otherwise -> focus_ (EApp1 si h (CheckType_ (sourceInfo b) t te) b) eet+ EApp1 si h te b+ | Pi h' x y <- et, h == h' -> checkN (EApp2 si h eet te) b x+ | Pi Hidden x y <- et, h == Visible -> focus_ (EApp1 mempty Hidden env $ Wildcard $ Wildcard SType) eet -- e b --> e _ b+-- | CheckType (Pi Hidden _ _) te' <- te -> error "ok"+-- | CheckAppType Hidden _ te' _ <- te -> error "ok"+ | otherwise -> infer (CheckType_ (sourceInfo b) (Var 2) $ cstr' h (up 2 et) (Pi Visible (Var 1) (Var 1)) (up 2 e) $ EBind2_ (sourceInfo b) BMeta TType $ EBind2_ (sourceInfo b) BMeta TType te) (up 3 b)+ where+ cstr' h x y e = EApp2 mempty h (evalCoe (up 1 x) (up 1 y) (Var 0) (up 1 e), up 1 y) . EBind2_ (sourceInfo b) BMeta (cstr TType x y)+ ELet2 ln (x{-let-}, xt) te -> focus_ te $ subst 0 (mkELet ln x xt){-let-} eet{-in-}+ CheckIType x te -> checkN te x e+ CheckType_ si t te+ | hArgs et > hArgs t+ -> focus_ (EApp1 mempty Hidden (CheckType_ si t te) $ Wildcard $ Wildcard SType) eet+ | hArgs et < hArgs t, Pi Hidden t1 t2 <- t+ -> focus_ (CheckType_ si t2 $ EBind2 (BLam Hidden) t1 te) eet+ | otherwise -> focus_ (EBind2_ si BMeta (cstr TType t et) te) $ up 1 eet+ EApp2 si h (a, at) te -> focus_' te si (app_ a e, appTy at e) -- h??+ EBind1 si h te b -> infer (EBind2_ (sourceInfo b) h e te) b+ EBind2_ si (BLam h) a te -> focus_ te $ lamPi h a eet+ EBind2_ si (BPi h) a te -> focus_' te si (Pi h a e, TType)+ _ -> focus2 env $ MEnd eet++ focus2 :: Env -> CEnv ExpType -> IM m ExpType'+ focus2 env eet = case env of+-- ELabelEnd te ->+ ELet1 le te b{-in-} -> infer (ELet2 le (replaceMetas' eet{-let-}) te) b{-in-}+ EBind2_ si BMeta tt_ te+ | ELabelEnd te' <- te -> refocus (ELabelEnd $ EBind2_ si BMeta tt_ te') eet+ | Unit <- tt -> refocus te $ subst 0 TT eet+ | Empty msg <- tt -> throwError' $ ETypeError msg si+ | T2 x y <- tt, let te' = EBind2_ si BMeta (up 1 y) $ EBind2_ si BMeta x te+ -> refocus te' $ subst 2 (t2C (Var 1) (Var 0)) $ up 2 eet+ | CstrT t a b <- tt, Just r <- cst (a, t) b -> r+ | CstrT t a b <- tt, Just r <- cst (b, t) a -> r+ | isCstr tt, EBind2 h x te' <- te{-, h /= BMeta todo: remove-}, Just x' <- down 0 tt, x == x'+ -> refocus te $ subst 1 (Var 0) eet+ | EBind2 h x te' <- te, h /= BMeta, Just b' <- down 0 tt+ -> refocus (EBind2_ si h (up 1 x) $ EBind2_ si BMeta b' te') $ subst 2 (Var 0) $ up 1 eet+ | ELet2 le (x, xt) te' <- te, Just b' <- down 0 tt+ -> refocus (ELet2 le (up 1 x, up 1 xt) $ EBind2_ si BMeta b' te') $ subst 2 (Var 0) $ up 1 eet+ | EBind1 si h te' x <- te -> refocus (EBind1 si h (EBind2_ si BMeta tt_ te') $ up1_ 1 x) eet+ | ELet1 le te' x <- te, floatLetMeta $ snd $ replaceMetas' $ Meta tt_ $ eet+ -> refocus (ELet1 le (EBind2_ si BMeta tt_ te') $ up1_ 1 x) eet+ | CheckAppType si h t te' x <- te -> refocus (CheckAppType si h (up 1 t) (EBind2_ si BMeta tt_ te') $ up1 x) eet+ | EApp1 si h te' x <- te -> refocus (EApp1 si h (EBind2_ si BMeta tt_ te') $ up1 x) eet+ | EApp2 si h x te' <- te -> refocus (EApp2 si h (up 1 x) $ EBind2_ si BMeta tt_ te') eet+ | CheckType_ si t te' <- te -> refocus (CheckType_ si (up 1 t) $ EBind2_ si BMeta tt_ te') eet+-- | CheckIType x te' <- te -> refocus (CheckType_ si (up 1 t) $ EBind2_ si BMeta tt te') eet+ | otherwise -> focus2 te $ Meta tt_ eet+ where+ tt = unfixlabel tt_+ refocus = refocus_ focus2+ cst :: ExpType -> Exp -> Maybe (IM m ExpType')+ cst x = \case+ Var i | fst (varType "X" i te) == BMeta+ , Just y <- down i x+ -> Just $ join swapAssign (\i x -> refocus $ EAssign i x te) i y $ subst 0 {-ReflCstr y-}TT $ subst (i+1) (fst $ up 1 y) eet+ _ -> Nothing++ EAssign i b te -> case te of+ ELabelEnd te' -> refocus' (ELabelEnd $ EAssign i b te') eet+ EBind2_ si h x te' | i > 0, Just b' <- down 0 b+ -> refocus' (EBind2_ si h (subst (i-1) (fst b') x) (EAssign (i-1) b' te')) eet+ ELet2 le (x, xt) te' | i > 0, Just b' <- down 0 b+ -> refocus' (ELet2 le (subst (i-1) (fst b') x, subst (i-1) (fst b') xt) (EAssign (i-1) b' te')) eet+ ELet1 le te' x -> refocus' (ELet1 le (EAssign i b te') $ substS (i+1) (up 1 b) x) eet+ EBind1 si h te' x -> refocus' (EBind1 si h (EAssign i b te') $ substS (i+1) (up 1 b) x) eet+ CheckAppType si h t te' x -> refocus' (CheckAppType si h (subst i (fst b) t) (EAssign i b te') $ substS i b x) eet+ EApp1 si h te' x -> refocus' (EApp1 si h (EAssign i b te') $ substS i b x) eet+ EApp2 si h x te' -> refocus' (EApp2 si h (subst i (fst b) x) $ EAssign i b te') eet+ CheckType_ si t te' -> refocus' (CheckType_ si (subst i (fst b) t) $ EAssign i b te') eet+ EAssign j a te' | i < j+ -> refocus' (EAssign (j-1) (subst i (fst b) a) $ EAssign i (up1_ (j-1) b) te') eet+ t | Just te' <- pull1 i b te -> refocus' te' eet+ | otherwise -> swapAssign (\i x -> focus2 te . Assign i x) (\i x -> refocus' $ EAssign i x te) i b eet+ -- todo: CheckSame Exp Env+ where+ refocus' = fix refocus_++ pull1 i b = \case+ EBind2_ si h x te | i > 0, Just b' <- down 0 b+ -> EBind2_ si h (subst (i-1) (fst b') x) <$> pull1 (i-1) b' te+ EAssign j a te+ | i < j -> EAssign (j-1) (subst i (fst b) a) <$> pull1 i (up1_ (j-1) b) te+ | j <= i -> EAssign j (subst i (fst b) a) <$> pull1 (i+1) (up1_ j b) te+ te -> pull i te++ pull i = \case+ EBind2 BMeta _ te | i == 0 -> Just te+ EBind2_ si h x te | i > 0 -> EBind2_ si h <$> down (i-1) x <*> pull (i-1) te+ EAssign j a te -> EAssign (if j <= i then j else j-1) <$> down i a <*> pull (if j <= i then i+1 else i) te+ _ -> Nothing++ EGlobal{} -> return eet+ _ -> case eet of+ MEnd x -> throwError' $ ErrorMsg $ "focus todo: " ++ ppShow x+ _ -> throwError' $ ErrorMsg $ "focus checkMetas: " ++ ppShow env ++ "\n" ++ ppShow (fst <$> eet)+ where+ refocus_ :: (Env -> CEnv ExpType -> IM m ExpType') -> Env -> CEnv ExpType -> IM m ExpType'+ refocus_ _ e (MEnd at) = focus_ e at+ refocus_ f e (Meta x at) = f (EBind2 BMeta x e) at+ refocus_ _ e (Assign i x at) = focus2 (EAssign i x e) at++ replaceMetas' = replaceMetas $ lamPi Hidden++lamPi h = (***) <$> const Lam <*> Pi h++replaceMetas bind = \case+ Meta a t -> bind a $ replaceMetas bind t+ Assign i x t | x' <- up1_ i x -> bind (cstr (snd x') (Var i) $ fst x') . up 1 . up1_ i $ replaceMetas bind t+ MEnd t -> t+++isCstr CstrT{} = True+isCstr (UFunN s [_]) = s `elem` [FEq, FOrd, FNum, FSigned, FComponent, FIntegral, FFloating] -- todo: use Constraint type to decide this+isCstr _ = {- trace_ (ppShow c ++ show c) $ -} False++-------------------------------------------------------------------------------- re-checking++type Message = String++recheck :: Message -> Env -> ExpType -> ExpType+recheck msg e = recheck' msg e++-- todo: check type also+recheck' :: Message -> Env -> ExpType -> ExpType+recheck' msg' e (x, xt) = (recheck_ "main" (checkEnv e) (x, xt), xt)+ where+ checkEnv = \case+ e@EGlobal{} -> e+ EBind1 si h e b -> EBind1 si h (checkEnv e) b+ EBind2_ si h t e -> EBind2_ si h (checkType e t) $ checkEnv e -- E [\(x :: t) -> e] -> check E [t]+ ELet1 le e b -> ELet1 le (checkEnv e) b+ ELet2 le x e -> ELet2 le (recheck'' "env" e x) $ checkEnv e+ EApp1 si h e b -> EApp1 si h (checkEnv e) b+ EApp2 si h a e -> EApp2 si h (recheck'' "env" e a) $ checkEnv e -- E [a x] -> check+ EAssign i x e -> EAssign i (recheck'' "env" e $ up1_ i x) $ checkEnv e -- __ <i := x>+ CheckType_ si x e -> CheckType_ si (checkType e x) $ checkEnv e+-- CheckSame x e -> CheckSame (recheck'' "env" e x) $ checkEnv e+ CheckAppType si h x e y -> CheckAppType si h (checkType e x) (checkEnv e) y++ recheck'' msg te a@(x, xt) = (recheck_ msg te a, xt)+ checkType te e = recheck_ "check" te (e, TType)++ recheck_ msg te = \case+ (Var k, zt) -> Var k -- todo: check var type+ (Lam_ md b, Pi h a bt) -> Lam_ md $ recheck_ "9" (EBind2 (BLam h) a te) (b, bt)+ (Pi_ md h a b, TType) -> Pi_ md h (checkType te a) $ checkType (EBind2 (BPi h) a te) b+ (ELit l, zt) -> ELit l -- todo: check literal type+ (TType, TType) -> TType+ (Neut (App__ md a b), zt)+ | (Neut a', at) <- recheck'' "app1" te (Neut a, neutType te a)+ -> checkApps "a" [] zt (Neut . App__ md a' . head) te at [b]+ (Con_ md s n as, zt) -> checkApps (show s) [] zt (Con_ md s n . drop (conParams s)) te (conType zt s) $ mkConPars n zt ++ as+ (TyCon_ md s as, zt) -> checkApps (show s) [] zt (TyCon_ md s) te (nType s) as+ (CaseFun s@(CaseFunName _ t pars) as n, zt) -> checkApps (show s) [] zt (\xs -> evalCaseFun s (init $ drop pars xs) (last xs)) te (nType s) (makeCaseFunPars te n ++ as ++ [Neut n])+ (TyCaseFun s [m, t, f] n, zt) -> checkApps (show s) [] zt (\[m, t, n, f] -> evalTyCaseFun s [m, t, f] n) te (nType s) [m, t, Neut n, f]+ (Neut (Fun_ md f vs@[] i a x), zt) -> checkApps "lab" [] zt (\xs -> Neut $ Fun_ md f vs i (reverse xs) x) te (nType f) $ reverse a -- TODO: recheck x+ -- TODO+ (r@(Neut (Fun' f vs i a x)), zt) -> r+ (LabelEnd x, zt) -> LabelEnd $ recheck_ msg te (x, zt)+ (Neut d@Delta{}, zt) -> Neut d+ where+ checkApps s acc zt f _ t []+ | t == zt = f $ reverse acc+ | otherwise = + error_ $ "checkApps' " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (t, TType) ++ "\n\n" ++ showEnvExp te (zt, TType)+ checkApps s acc zt f te t@(unfixlabel -> Pi h x y) (b_: xs) = checkApps (s++"+") (b: acc) zt f te (appTy t b) xs where b = recheck_ "checkApps" te (b_, x)+ checkApps s acc zt f te t _ =+ error_ $ "checkApps " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (t, TType) ++ "\n\n" ++ showEnvExp e (x, xt)++-- Ambiguous: (Int ~ F a) => Int+-- Not ambiguous: (Show a, a ~ F b) => b+ambiguityCheck :: String -> Exp -> Maybe String+ambiguityCheck s ty = case ambigVars ty of+ [] -> Nothing+ err -> Just $ s ++ " has ambiguous type:\n" ++ ppShow ty ++ "\nproblematic vars:\n" ++ show err++ambigVars :: Exp -> [(Int, Exp)]+ambigVars ty = [(n, c) | (n, c) <- hid, not $ any (`Set.member` defined) $ Set.insert n $ free c]+ where+ (defined, hid, i) = compDefined False ty++floatLetMeta :: Exp -> Bool+floatLetMeta ty = (i-1) `Set.member` defined+ where+ (defined, hid, i) = compDefined True ty++compDefined b ty = (defined, hid, i)+ where+ defined = dependentVars hid $ Set.map (if b then (+i) else id) $ free ty++ i = length hid_+ hid = zipWith (\k t -> (k, up (k+1) t)) (reverse [0..i-1]) hid_+ (hid_, ty') = hiddenVars ty++hiddenVars (Pi Hidden a b) = first (a:) $ hiddenVars b+hiddenVars t = ([], t)++-- compute dependent type vars in constraints+-- Example: dependentVars [(a, b) ~ F b c, d ~ F e] [c] == [a,b,c]+dependentVars :: [(Int, Exp)] -> Set.Set Int -> Set.Set Int+dependentVars ie = cycle mempty+ where+ freeVars = free++ cycle acc s+ | Set.null s = acc+ | otherwise = cycle (acc <> s) (grow s Set.\\ acc)++ grow = flip foldMap ie $ \case+ (n, t) -> (Set.singleton n <-> freeVars t) <> case t of+ CstrT _{-todo-} ty f -> freeVars ty <-> freeVars f+ CSplit a b c -> freeVars a <-> (freeVars b <> freeVars c)+ _ -> mempty+ where+ a --> b = \s -> if Set.null $ a `Set.intersection` s then mempty else b+ a <-> b = (a --> b) <> (b --> a)+++-------------------------------------------------------------------------------- global env++type GlobalEnv = Map.Map SName (Exp, Type, SI)++initEnv :: GlobalEnv+initEnv = Map.fromList+ [ (,) "'Type" (TType, TType, debugSI "source-of-Type")+ ]++-------------------------------------------------------------------------------- infos++data Info+ = Info Range String+ | IType String String+ | ITrace String String+ | IError ErrorMsg++instance NFData Info+ where+ rnf = \case+ Info r s -> rnf (r, s)+ IType a b -> rnf (a, b)+ ITrace i s -> rnf (i, s)+ IError x -> rnf x++instance Show Info where+ show = \case+ Info r s -> ppShow r ++ " " ++ s+ IType a b -> a ++ " :: " ++ correctEscs b+ ITrace i s -> i ++ ": " ++ correctEscs s+ IError e -> "!" ++ show e++errorRange is = [r | IError e <- is, RangeSI r <- errorRange_ e ]++type Infos = [Info]++throwError' e = tell [IError e] >> throwError e++mkInfoItem (RangeSI r) i = [Info r i]+mkInfoItem _ _ = mempty++listAllInfos m = h "trace" (listTraceInfos m)+ ++ h "tooltips" [ ppShow r ++ " " ++ intercalate " | " is | (r, is) <- listTypeInfos m ]+ where+ h x [] = []+ h x xs = ("------------ " ++ x) : xs++listTraceInfos m = [show i | i <- m, case i of Info{} -> False; _ -> True]+listTypeInfos m = map (second Set.toList) $ Map.toList $ Map.unionsWith (<>) [Map.singleton r $ Set.singleton i | Info r i <- m]++-------------------------------------------------------------------------------- inference for statements++inference :: MonadFix m => [Stmt] -> IM m [GlobalEnv]+inference [] = return []+inference (x:xs) = do+ y <- handleStmt x+ (y:) <$> withEnv y (inference xs)++modn = 0++handleStmt :: MonadFix m => Stmt -> IM m GlobalEnv+handleStmt = \case+ Primitive n (trSExp' -> t_) -> do+ t <- inferType =<< ($ t_) <$> addF+ tellType (fst n) t+ addToEnv n $ flip (,) t $ lamify t $ Neut . DFun_ (FunName (cFName modn 0 n) Nothing t)+ Let n mt t_ -> do+ af <- addF+ let t__ = maybe id (flip SAnn . af) mt t_+ (x, t) <- inferTerm (snd n) $ trSExp' $ if usedS n t__ then SBuiltin "primFix" `SAppV` SLamV (substSG0 n t__) else t__+ tellType (fst n) t+ addToEnv n (mkELet n x t, t)+{- -- hack+ when (snd (getParams t) == TType) $ do+ let ps' = fst $ getParams t+ t'' = (TType :~> TType)+ :~> addParams ps' (Var (length ps') `app_` DFun (FunName (snd n) t) (downTo 0 $ length ps'))+ :~> TType+ :~> Var 2 `app_` Var 0+ :~> Var 3 `app_` Var 1+ addToEnv (fst n, MatchName (snd n)) (lamify t'' $ \[m, tr, n', f] -> evalTyCaseFun (TyCaseFunName (snd n) t) [m, tr, f] n', t'')+-}+ PrecDef{} -> return mempty+ Data s (map (second trSExp') -> ps) (trSExp' -> t_) addfa (map (second trSExp') -> cs) -> do+ af <- if addfa then asks $ \(exs, ge) -> addForalls exs . (snd s:) . defined' $ ge else return id+ vty <- inferType $ addParamsS ps t_+ tellType (fst s) vty+ let+ sint = cFName modn 2 s+ pnum' = length $ filter ((== Visible) . fst) ps+ inum = arity vty - length ps++ mkConstr j (cn, af -> ct)+ | c == SGlobal s && take pnum' xs == downToS "a3" (length . fst . getParamsS $ ct) pnum'+ = do+ cty <- removeHiddenUnit <$> inferType (addParamsS [(Hidden, x) | (Visible, x) <- ps] ct)+ tellType (fst cn) cty+ let pars = zipWith (\x -> second $ STyped (debugSI "mkConstr1") . flip (,) TType . up_ (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty+ act = length . fst . getParams $ cty+ acts = map fst . fst . getParams $ cty+ conn = ConName (cFName modn 1 cn) j cty+ e <- addToEnv cn (Con conn 0 [], cty)+ return (e, ((conn, cty)+ , addParamsS pars+ $ foldl SAppV (SVar (debugSI "22", ".cs") $ j + length pars) $ drop pnum' xs ++ [apps' (SGlobal cn) (zip acts $ downToS ("a4 " ++ snd cn ++ " " ++ show (length ps)) (j+1+length pars) (length ps) ++ downToS "a5" 0 (act- length ps))]+ ))+ | otherwise = throwError' $ ErrorMsg "illegal data definition (parameters are not uniform)" -- ++ show (c, cn, take pnum' xs, act)+ where+ (c, map snd -> xs) = getApps $ snd $ getParamsS ct++ motive = addParamsS (replicate inum (Visible, Wildcard SType)) $+ SPi Visible (apps' (SGlobal s) $ zip (map fst ps) (downToS "a6" inum $ length ps) ++ zip (map fst $ fst $ getParamsS t_) (downToS "a7" 0 inum)) SType++ (e1, es, tcn, cfn@(CaseFunName _ ct _), _, _) <- mfix $ \ ~(_, _, _, _, ct', cons') -> do+ let cfn = CaseFunName sint ct' $ length ps+ let tcn = TyConName sint inum vty (map fst cons') cfn+ e1 <- addToEnv s (TyCon tcn [], vty)+ (unzip -> (mconcat -> es, cons)) <- withEnv e1 $ zipWithM mkConstr [0..] cs+ ct <- withEnv (e1 <> es) $ inferType+ ( (\x -> traceD ("type of case-elim before elaboration: " ++ ppShow x) x) $ addParamsS+ ( [(Hidden, x) | (_, x) <- ps]+ ++ (Visible, motive)+ : map ((,) Visible . snd) cons+ ++ replicate inum (Hidden, Wildcard SType)+ ++ [(Visible, apps' (SGlobal s) $ zip (map fst ps) (downToS "a8" (inum + length cs + 1) $ length ps) ++ zip (map fst $ fst $ getParamsS t_) (downToS "a9" 0 inum))]+ )+ $ foldl SAppV (SVar (debugSI "23", ".ct") $ length cs + inum + 1) $ downToS "a10" 1 inum ++ [SVar (debugSI "24", ".24") 0]+ )+ return (e1, es, tcn, cfn, ct, cons)++ e2 <- addToEnv (fst s, caseName (snd s)) (lamify ct $ \xs -> evalCaseFun cfn (init $ drop (length ps) xs) (last xs), ct)+ let ps' = fst $ getParams vty+ t = (TType :~> TType)+ :~> addParams ps' (Var (length ps') `app_` TyCon tcn (downTo 0 $ length ps'))+ :~> TType+ :~> Var 2 `app_` Var 0+ :~> Var 3 `app_` Var 1+ e3 <- addToEnv (fst s, MatchName (snd s)) (lamify t $ \[m, tr, n, f] -> evalTyCaseFun (TyCaseFunName sint t) [m, tr, f] n, t)+ return (e1 <> e2 <> e3 <> es)++ stmt -> error $ "handleStmt: " ++ show stmt++withEnv e = local $ second (<> e)++mkELet n x xt = {-(if null vs then id else trace_ $ "mkELet " ++ show (length vs) ++ " " ++ show n)-} term+ where+ vs = [Var i | i <- Set.toList $ free x <> free xt]+ fn = FunName (cFName modn 5 n) (Just x) xt++ term = pmLabel fn vs 0 [] $ getFix x 0++ getFix (Lam z) i = Lam $ getFix z (i+1)+ getFix (TFun FprimFix _ [t, Lam f]) i = (if null vs then id else trace_ "!local rec") $ subst 0 (foldl app_ term (downTo 0 i)) f+ getFix x _ = x+++removeHiddenUnit (Pi Hidden Unit (down 0 -> Just t)) = removeHiddenUnit t+removeHiddenUnit (Pi h a b) = Pi h a $ removeHiddenUnit b+removeHiddenUnit t = t++addParams ps t = foldr (uncurry Pi) t ps++addLams ps t = foldr (const Lam) t ps++lamify t x = addLams (fst $ getParams t) $ x $ downTo 0 $ arity t++{-+getApps' = second reverse . run where+ run (App a b) = second (b:) $ run a+ run x = (x, [])+-}+arity :: Exp -> Int+arity = length . fst . getParams++getParams :: Exp -> ([(Visibility, Exp)], Exp)+getParams (Pi h a b) = first ((h, a):) $ getParams b+getParams x = ([], x)++getLams (Lam b) = getLams b+getLams x = x++inferTerm :: Monad m => String -> SExp2 -> IM m ExpType+inferTerm msg t =+ fmap ((closedExp *** closedExp) . recheck msg EGlobal . replaceMetas (lamPi Hidden)) $ inferN EGlobal t+inferType :: Monad m => SExp2 -> IM m Type+inferType t = fmap (closedExp . fst . recheck "inferType" EGlobal . flip (,) TType . replaceMetas (Pi Hidden) . fmap fst) $ inferN (CheckType_ (debugSI "inferType CheckType_") TType EGlobal) t++addToEnv :: Monad m => SIName -> ExpType -> IM m GlobalEnv+addToEnv (si, s) (x, t) = do+-- maybe (pure ()) throwError_ $ ambiguityCheck s t -- TODO+-- b <- asks $ (TraceTypeCheck `elem`) . fst+ tell [IType s $ ppShow t]+ v <- asks $ Map.lookup s . snd+ case v of+ Nothing -> return $ Map.singleton s (closedExp x, closedExp t, si)+ Just (_, _, si') -> throwError' $ ERedefined s si si'+{-+joinEnv :: Monad m => GlobalEnv -> GlobalEnv -> IM m GlobalEnv+joinEnv e1 e2 = do+-}++downTo n m = map Var [n+m-1, n+m-2..n]++defined' = Map.keys++-- todo: proper handling of implicit foralls+addF = asks $ \(exs, ge) -> addForalls exs $ defined' ge++tellType si t = tell $ mkInfoItem (sourceInfo si) $ removeEscs $ showDoc $ mkDoc True (t, TType)+++-------------------------------------------------------------------------------- pretty print+-- todo: do this via conversion to SExp++instance PShow Exp where+ pShowPrec _ = showDoc_ . mkDoc False++instance PShow (CEnv Exp) where+ pShowPrec _ = showDoc_ . mkDoc False++instance PShow Env where+ pShowPrec _ e = showDoc_ $ envDoc e $ pure $ shAtom $ underlined "<<HERE>>"++showEnvExp :: Env -> ExpType -> String+showEnvExp e c = showDoc $ envDoc e $ epar <$> mkDoc False c++showEnvSExp :: Up a => Env -> SExp' a -> String+showEnvSExp e c = showDoc $ envDoc e $ epar <$> sExpDoc c++showEnvSExpType :: Up a => Env -> SExp' a -> Exp -> String+showEnvSExpType e c t = showDoc $ envDoc e $ epar <$> (shAnn "::" False <$> sExpDoc c <**> mkDoc False (t, TType))+ where+ infixl 4 <**>+ (<**>) :: NameDB (a -> b) -> NameDB a -> NameDB b+ a <**> b = get >>= \s -> lift $ evalStateT a s <*> evalStateT b s++{-+expToSExp :: Exp -> SExp+expToSExp = \case+ Fun x _ -> expToSExp x+-- Var k -> shAtom <$> shVar k+ App a b -> SApp Visible{-todo-} (expToSExp a) (expToSExp b)+{-+ Lam h a b -> join $ shLam (used 0 b) (BLam h) <$> f a <*> pure (f b)+ Bind h a b -> join $ shLam (used 0 b) h <$> f a <*> pure (f b)+ Cstr a b -> shCstr <$> f a <*> f b+ MT s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs+ CaseFun s xs -> foldl (shApp Visible) (shAtom $ show s) <$> mapM f xs+ TyCaseFun s xs -> foldl (shApp Visible) (shAtom $ show s) <$> mapM f xs+ ConN s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs+ TyConN s xs -> foldl (shApp Visible) (shAtom s) <$> mapM f xs+-- TType -> pure $ shAtom "Type"+ ELit l -> pure $ shAtom $ show l+ Assign i x e -> shLet i (f x) (f e)+ LabelEnd x -> shApp Visible (shAtom "labend") <$> f x+-}+nameSExp :: SExp -> NameDB SExp+nameSExp = \case+ SGlobal s -> pure $ SGlobal s+ SApp h a b -> SApp h <$> nameSExp a <*> nameSExp b+ SBind h a b -> newName >>= \n -> SBind h <$> nameSExp a <*> local (n:) (nameSExp b)+ SLet a b -> newName >>= \n -> SLet <$> nameSExp a <*> local (n:) (nameSExp b)+ STyped_ x (e, _) -> nameSExp $ expToSExp e -- todo: mark boundary+ SVar i -> SGlobal <$> shVar i+-}+envDoc :: Env -> Doc -> Doc+envDoc x m = case x of+ EGlobal{} -> m+ EBind1 _ h ts b -> envDoc ts $ join $ shLam (used 0 b) h <$> m <*> pure (sExpDoc b)+ EBind2 h a ts -> envDoc ts $ join $ shLam True h <$> mkDoc ts' (a, TType) <*> pure m+ EApp1 _ h ts b -> envDoc ts $ shApp h <$> m <*> sExpDoc b+ EApp2 _ h (Lam (Var 0), Pi Visible TType _) ts -> envDoc ts $ shApp h (shAtom "tyType") <$> m+ EApp2 _ h a ts -> envDoc ts $ shApp h <$> mkDoc ts' a <*> m+ ELet1 _ ts b -> envDoc ts $ shLet_ m (sExpDoc b)+ ELet2 _ x ts -> envDoc ts $ shLet_ (mkDoc ts' x) m+ EAssign i x ts -> envDoc ts $ shLet i (mkDoc ts' x) m+ CheckType t ts -> envDoc ts $ shAnn ":" False <$> m <*> mkDoc ts' (t, TType)+ CheckIType t ts -> envDoc ts $ shAnn ":" False <$> m <*> pure (shAtom "??") -- mkDoc ts' t+-- CheckSame t ts -> envDoc ts $ shCstr <$> m <*> mkDoc ts' t+ CheckAppType si h t te b -> envDoc (EApp1 si h (CheckType_ (sourceInfo b) t te) b) m+ ELabelEnd ts -> envDoc ts $ shApp Visible (shAtom "labEnd") <$> m+ x -> error $ "envDoc: " ++ show x+ where+ ts' = False++class MkDoc a where+ mkDoc :: Bool -> a -> Doc++instance MkDoc ExpType where+ mkDoc ts e = mkDoc ts $ fst e++instance MkDoc Exp where+ mkDoc ts e = fmap inGreen <$> f e+ where+ f = \case+-- Lam h a b -> join $ shLam (used 0 b) (BLam h) <$> f a <*> pure (f b)+ Lam b -> join $ shLam True (BLam Visible) <$> f TType{-todo!-} <*> pure (f b)+ Pi h a b -> join $ shLam (used 0 b) (BPi h) <$> f a <*> pure (f b)+ ENat' n -> pure $ shAtom $ show n+ (getTTup -> Just xs) -> shTuple <$> mapM f xs+ (getTup -> Just xs) -> shTuple <$> mapM f xs+ Con s _ xs -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM f xs+ TyConN s xs -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM f xs+ TType -> pure $ shAtom "Type"+ ELit l -> pure $ shAtom $ show l+ Neut x -> mkDoc ts x++ shAtom_ = shAtom . if ts then switchTick else id++instance MkDoc Neutral where+ mkDoc ts e = fmap inGreen <$> f e+ where+ g = mkDoc ts+ f = \case+ CstrT' t a b -> shCstr <$> g (a, t) <*> g (b, t)+ Fun' s vs i (mkExpTypes (nType s) . reverse -> xs) _ -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g xs+ Var_ k -> shAtom <$> shVar k+ App_ a b -> shApp Visible <$> g a <*> g b+ CaseFun_ s xs n -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g ({-mkExpTypes (nType s) $ makeCaseFunPars te n ++ -} xs ++ [Neut n])+ TyCaseFun_ s [m, t, f] n -> foldl (shApp Visible) (shAtom_ $ show s) <$> mapM g (mkExpTypes (nType s) [m, t, Neut n, f])+ TyCaseFun_ s _ n -> error $ "mkDoc TyCaseFun"+ LabelEnd_ x -> shApp Visible (shAtom $ "labend") <$> g x+ Delta{} -> return $ shAtom "^delta"++ shAtom_ = shAtom . if ts then switchTick else id++instance MkDoc (CEnv Exp) where+ mkDoc ts e = fmap inGreen <$> f e+ where+ f :: CEnv Exp -> Doc+ f = \case+ MEnd a -> mkDoc ts a+ Meta a b -> join $ shLam True BMeta <$> mkDoc ts a <*> pure (f b)+ Assign i (x, _) e -> shLet i (mkDoc ts x) (f e)++getTup (unfixlabel -> ConN FHCons [_, _, x, xs]) = (x:) <$> getTup xs+getTup (unfixlabel -> ConN FHNil []) = Just []+getTup _ = Nothing++getTTup (unfixlabel -> TyConN FHList [xs]) = getList xs+getTTup _ = Nothing++getList (unfixlabel -> ConN FCons [x, xs]) = (x:) <$> getList xs+getList (unfixlabel -> ConN FNil []) = Just []+getList _ = Nothing++-------------------------------------------------------------------------------- tools++mfix' f = ExceptT (mfix (runExceptT . f . either bomb id))+ where bomb e = error $ "mfix (ExceptT): inner computation returned Left value:\n" ++ show e++foldlrev f = foldr (flip f)
src/LambdaCube/Compiler/Lexer.hs view
@@ -1,4 +1,3 @@--- contains modified Haskell source code copied from Text.Parsec.Token, see below {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-}@@ -22,92 +21,18 @@ import qualified Data.Map as Map import Control.Monad.Except-import Control.Monad.Reader-import Control.Monad.Writer+import Control.Monad.RWS import Control.Arrow hiding ((<+>)) import Control.Applicative import Control.DeepSeq -import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens)----------------------- parsec specific code begins here-import Text.Parsec hiding ((<|>), many)-import Text.Parsec as Pr hiding (label, Empty, State, (<|>), many, try)-import qualified Text.Parsec as Pa-import Text.Parsec.Indentation as Pa-import Text.Parsec.Indentation.Char-import Text.Parsec.Pos--skipSome = skipMany1--type P = ParsecT (IndentStream (CharIndentStream String)) SourcePos InnerP--indent s p = reserved s *> localIndentation Ge (localAbsoluteIndentation p)-indented = localIndentation Gt-indentMany s p = indent s $ many p-indentSome s p = indent s $ some p-indentMany' = many--whiteSpace = ignoreAbsoluteIndentation (localTokenMode (const Pa.Any) whiteSpace')--lexeme p- = p <* (getPosition >>= setState >> whiteSpace)--mkStream = mkIndentStream 0 infIndentation True Ge . mkCharIndentStream--runPT' p st --u name s- = do res <- runParsecT p st -- (Pa.State s (initialPos name) u)- r <- parserReply res- case r of- Ok x _ _ -> return (Right x)- Error err -> return (Left err)- where- parserReply res- = case res of- Consumed r -> r- Pa.Empty r -> r--runParserT'' p f = runParserT p (initialPos f) f---------------------- parsec specific code ends here-{----------------------- megaparsec specific code begins here-import Control.Monad.State import Text.Megaparsec-import Text.Megaparsec.Lexer hiding (lexeme, symbol, space, negate) import Text.Megaparsec as Pr hiding (try, label, Message)+import Text.Megaparsec.Lexer hiding (lexeme, symbol, space, negate, symbol', indentBlock) import Text.Megaparsec.Pos -optionMaybe = optional-runParserT'' p f = flip evalStateT (initialPos f, 0) . runParserT p f--runPT' p st = snd <$> flip evalStateT (initialPos ".....", 0) (runParserT' p st)-mkStream = id-hexDigit = hexDigitChar-octDigit = octDigitChar-digit = digitChar-getState = fst <$> get--type P = ParsecT String (StateT (SourcePos, Int) InnerP)--indentMany' p = --many p--- indentBlock whiteSpace' $ whiteSpace' >> return (IndentMany Nothing return p)-indentMany s p = indentBlock whiteSpace' $ try (reserved s) *> return (IndentMany Nothing return p)-indentSome s p = indentBlock whiteSpace' $ try (reserved s) *> return (IndentSome Nothing return p)-indented p = do- i <- indentLevel- modify $ second $ const i- --p <* indentGuard whiteSpace' (>= i)- p--lexeme p = do- i <- indentLevel- i' <- snd <$> get--- when (i < i') $ fail "indent level"- p <* (getPosition >>= \p -> modify (first $ const p) >> whiteSpace)+import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) -whiteSpace = whiteSpace'---------------------- megaparsec specific code ends here--} -------------------------------------------------------------------------------- parser utils -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602@@ -120,23 +45,28 @@ -------------------------------------------------------------------------------- parser type -type InnerP = WriterT [PostponedCheck] (Reader (DesugarInfo, Namespace))+type P = ParsecT String (RWS ((DesugarInfo, Namespace), (Int, Int){-indentation level-}) [PostponedCheck] SourcePos) type PostponedCheck = Maybe String type DesugarInfo = (FixityMap, ConsMap) type ConsMap = Map.Map SName{-constructor name-}- (Either ((SName{-type name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-})+ (Either ((SName{-case eliminator name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-}) Int{-arity-}) dsInfo :: P DesugarInfo-dsInfo = asks fst+dsInfo = asks $ fst . fst namespace :: P Namespace-namespace = asks snd+namespace = asks $ snd . fst +runP_ r f p = (\(a, s, w) -> (a, w)) $ runRWS p (r, (0, 0)) (initialPos f) +runP r f p s = runP_ r f $ runParserT p f s++runP' r f p st = runP_ r f $ runParserT' p st+ -------------------------------------------------------------------------------- literals data Lit@@ -157,7 +87,13 @@ type SName = String +pattern CaseName :: String -> String+pattern CaseName cs <- (getCaseName -> Just cs) where CaseName = caseName+ caseName (c:cs) = toLower c: cs ++ "Case"+getCaseName cs = case splitAt 4 $ reverse cs of+ (reverse -> "Case", xs) -> Just $ reverse xs+ _ -> Nothing pattern MatchName cs <- (getMatchName -> Just cs) where MatchName = matchName @@ -189,6 +125,11 @@ = NoSI (Set.Set String) -- no source info, attached debug info | RangeSI Range +instance NFData SI where+ rnf = \case+ NoSI x -> rnf x+ RangeSI r -> rnf r+ instance Show SI where show _ = "SI" instance Eq SI where _ == _ = True instance Ord SI where _ `compare` _ = EQ@@ -204,15 +145,17 @@ pShowPrec _ (NoSI ds) = hsep $ map pShow $ Set.toList ds pShowPrec _ (RangeSI r) = pShow r -showSI_ _ (NoSI ds) = unwords $ Set.toList ds-showSI_ source (RangeSI (Range s e)) = show str- where- startLine = sourceLine s - 1- endline = sourceLine e - if sourceColumn e == 1 then 1 else 0- len = endline - startLine- str = vcat $ text (show s <> ":"){- <+> "-" <+> text (show e)-}:- map text (take len $ drop startLine $ lines source)- ++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1]+showSI _ (NoSI ds) = unwords $ Set.toList ds+showSI srcs si@(RangeSI (Range s e)) = case Map.lookup (sourceName s) srcs of+ Just source -> show str+ where+ startLine = sourceLine s - 1+ endline = sourceLine e - if sourceColumn e == 1 then 1 else 0+ len = endline - startLine+ str = vcat $ text (show s <> ":"){- <+> "-" <+> text (show e)-}:+ map text (take len $ drop startLine $ lines source)+ ++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1]+ Nothing -> showSourcePosSI si showSourcePosSI (NoSI ds) = unwords $ Set.toList ds showSourcePosSI (RangeSI (Range s _)) = show s@@ -228,7 +171,7 @@ sourceNameSI (RangeSI (Range a _)) = sourceName a -sameSource r@(RangeSI {}) q@(RangeSI {}) = sourceNameSI r == sourceNameSI q+sameSource r@RangeSI{} q@RangeSI{} = sourceNameSI r == sourceNameSI q sameSource _ _ = True class SourceInfo si where@@ -244,61 +187,47 @@ setSI :: SI -> a -> a appRange :: P (SI -> a) -> P a-appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> getState--withRange :: (SI -> a -> b) -> P a -> P b-withRange f p = appRange $ flip f <$> p--infix 9 `withRange`+appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> get type SIName = (SI, SName) -parseSIName :: P String -> P SIName-parseSIName = withRange (,)+-- todo: eliminate+psn p = appRange $ flip (,) <$> p -------------------------------------------------------------------------------- namespace handling -data Level = TypeLevel | ExpLevel+data Namespace = TypeNS | ExpNS deriving (Eq, Show) -data Namespace = Namespace- { namespaceLevel :: Maybe Level- , constructorNamespace :: Bool -- True means that the case of the first letter of identifiers matters- }- deriving (Show)--tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel+tick = (\case TypeNS -> switchTick; _ -> id) tick' c = (`tick` c) <$> namespace +switchNamespace = \case ExpNS -> TypeNS; TypeNS -> ExpNS+ switchTick ('\'': n) = n switchTick n = '\'': n -modifyLevel f = local $ second $ \(Namespace l p) -> Namespace (f <$> l) p+modifyLevel f = local $ first $ second f typeNS, expNS, switchNS :: P a -> P a-typeNS = modifyLevel $ const TypeLevel-expNS = modifyLevel $ const ExpLevel-switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel--ifNoCNamespace p = namespace >>= \ns -> if constructorNamespace ns then mzero else p+typeNS = modifyLevel $ const TypeNS+expNS = modifyLevel $ const ExpNS+switchNS = modifyLevel $ switchNamespace -------------------------------------------------------------------------------- identifiers -lcIdentStart = satisfy $ \c -> isLower c || c == '_'+lowerLetter = satisfy $ \c -> isLower c || c == '_'+upperLetter = satisfy isUpper identStart = satisfy $ \c -> isLetter c || c == '_' identLetter = satisfy $ \c -> isAlphaNum c || c == '_' || c == '\'' || c == '#' lowercaseOpLetter = oneOf "!#$%&*+./<=>?@\\^|-~"-opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+opLetter = lowercaseOpLetter <|> char ':' maybeStartWith p i = i <|> (:) <$> satisfy p <*> i -lowerLetter = lcIdentStart <|> ifNoCNamespace identStart-upperLetter = satisfy isUpper <|> ifNoCNamespace identStart--upperCase, lowerCase, symbols, colonSymbols, backquotedIdent :: P SName--upperCase = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident"+upperCase = identifier (tick' =<< (:) <$> upperLetter <*> many identLetter) <?> "uppercase ident"+upperCase_ = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) <?> "uppercase ident" lowerCase = identifier ((:) <$> lowerLetter <*> many identLetter) <?> "lowercase ident" backquotedIdent = identifier ((:) <$ char '`' <*> identStart <*> many identLetter <* char '`') <?> "backquoted ident" symbols = operator (some opLetter) <?> "symbols"@@ -306,21 +235,18 @@ colonSymbols = operator ((:) <$> satisfy (== ':') <*> many opLetter) <?> "op symbols" moduleName = identifier (intercalate "." <$> sepBy1 ((:) <$> upperLetter <*> many identLetter) (char '.')) <?> "module name" -patVar = f <$> lowerCase where+patVar = second f <$> lowerCase where f "_" = "" f x = x lhsOperator = lcSymbols <|> backquotedIdent rhsOperator = symbols <|> backquotedIdent-varId = lowerCase <|> parens rhsOperator-upperLower = lowerCase <|> upperCase <|> parens rhsOperator----qIdent = {-qualified_ todo-} (lowerCase <|> upperCase)+varId = lowerCase <|> parens (symbols <|> backquotedIdent)+upperLower = lowerCase <|> upperCase_ <|> parens symbols -------------------------------------------------------------------------------- fixity handling data FixityDef = Infix | InfixL | InfixR deriving (Show) type Fixity = (FixityDef, Int)-type MFixity = Maybe Fixity type FixityMap = Map.Map SName Fixity calcPrec@@ -353,262 +279,174 @@ parseFixityDecl :: P [(SIName, Fixity)] parseFixityDecl = do- dir <- Infix <$ reserved "infix"- <|> InfixL <$ reserved "infixl"- <|> InfixR <$ reserved "infixr"- indented $ do+ dir <- Infix <$ reserved "infix"+ <|> InfixL <$ reserved "infixl"+ <|> InfixR <$ reserved "infixr" LInt n <- parseLit let i = fromIntegral n- ns <- commaSep1 (parseSIName rhsOperator)+ ns <- commaSep1 rhsOperator return $ (,) <$> ns <*> pure (dir, i) getFixity :: DesugarInfo -> SName -> Fixity getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm ------------------------------------------------------------------------------------------------------------------------------------------------- modified version of------ Module : Text.Parsec.Token--- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007--- License : BSD-style+----------------------------------------------------------- operators and identifiers --------------------------------------------------------------- Bracketing-------------------------------------------------------------parens p = between (symbol "(") (symbol ")") p-braces p = between (symbol "{") (symbol "}") p-angles p = between (symbol "<") (symbol ">") p-brackets p = between (symbol "[") (symbol "]") p+reservedOp name = lexeme $ try $ string name *> notFollowedBy opLetter -commaSep p = sepBy p $ symbol ","-commaSep1 p = sepBy1 p $ symbol ","+reserved name = lexeme $ try $ string name *> notFollowedBy identLetter ------------------------------------------------------------+expect msg p i = i >>= \n -> if p n then unexpected (msg ++ " " ++ show n) else return n -parseLit = lexeme $ charLiteral <|> stringLiteral <|> natFloat+identifier ident = lexeme_ $ try $ expect "reserved word" (`Set.member` theReservedNames) ident++operator oper = lexeme_ $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper where- ------------------------------------------------------------ -- Chars & Strings- ------------------------------------------------------------ charLiteral = LChar <$> between (char '\'')- (char '\'' <?> "end of character")- characterChar- <?> "character"+ trCons ":" = "Cons"+ trCons x = x - characterChar = charLetter <|> charEscape- <?> "literal character"+theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"] - charEscape = do{ char '\\'; escapeCode }- charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))+theReservedNames = Set.fromList $+ ["let","in","case","of","if","then","else"+ ,"data","type"+ ,"class","default","deriving","do","import"+ ,"infix","infixl","infixr","instance","module"+ ,"newtype","where"+ ,"primitive"+ -- "as","qualified","hiding"+ ] +++ ["foreign","import","export","primitive"+ ,"_ccall_","_casm_"+ ,"forall"+ ] +----------------------------------------------------------- indentation, white space, symbols +checkIndent = do+ (r, c) <- asks snd+ pos <- getPosition+ if (sourceColumn pos <= c && sourceLine pos /= r) then fail "wrong indentation" else return pos - stringLiteral = LString <$> - do{ str <- between (char '"')- (char '"' <?> "end of string")- (many stringChar)- ; return (foldr (maybe id (:)) "" str)- }- <?> "literal string"+indentMS null p = (if null then option [] else id) $ do+ pos' <- checkIndent+ (if null then many else some) $ do+ pos <- getPosition+ guard (sourceColumn pos == sourceColumn pos')+ local (second $ const (sourceLine pos, sourceColumn pos)) p - stringChar = do{ c <- stringLetter; return (Just c) }- <|> stringEscape- <?> "string character"+lexeme' sp p = do+ p1 <- checkIndent+ x <- p+ p2 <- getPosition+ put p2+ sp+ return (RangeSI $ Range p1 p2, x) - stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))+lexeme = fmap snd . lexeme' whiteSpace - stringEscape = do{ char '\\'- ; do{ escapeGap ; return Nothing }- <|> do{ escapeEmpty; return Nothing }- <|> do{ esc <- escapeCode; return (Just esc) }- }+lexeme_ = lexeme' whiteSpace - escapeEmpty = char '&'- escapeGap = do{ some space- ; char '\\' <?> "end of string gap"- }+----------------------------------------------------------------------+----------------------------------------------------------------------+-- based on+--+-- Module : Text.Parsec.Token+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License : BSD-style +symbol = symbol' whiteSpace +symbol' sp name+ = lexeme' sp (string name) - -- escape codes- escapeCode = charEsc <|> charNum <|> charAscii <|> charControl- <?> "escape code"+whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "") - charControl = do{ char '^'- ; code <- satisfy isUpper <?> "uppercase letter"- ; return (toEnum (fromEnum code - fromEnum 'A'))- }+simpleSpace+ = skipSome (satisfy isSpace) - charNum = do{ code <- decimal- <|> do{ char 'o'; number 8 octDigit }- <|> do{ char 'x'; number 16 hexDigit }- ; return (toEnum (fromInteger code))- }+oneLineComment+ = try (string "--" >> many (char '-') >> notFollowedBy opLetter)+ >> skipMany (satisfy (/= '\n')) - charEsc = choice (map parseEsc escMap)- where- parseEsc (c,code) = do{ char c; return code }+multiLineComment = try (string "{-") *> inCommentMulti - charAscii = choice (map parseAscii asciiMap)- where- parseAscii (asc,code) = try (do{ string asc; return code })+inCommentMulti+ = try (() <$ string "-}")+ <|> multiLineComment *> inCommentMulti+ <|> skipSome (noneOf "{}-") *> inCommentMulti+ <|> oneOf "{}-" *> inCommentMulti+ <?> "end of comment" - -- escape code tables- escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")- asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)+parens = between (symbol "(") (symbol ")")+braces = between (symbol "{") (symbol "}")+brackets = between (symbol "[") (symbol "]") - ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",- "FS","GS","RS","US","SP"]- ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",- "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",- "CAN","SUB","ESC","DEL"]+commaSep p = sepBy p $ symbol ","+commaSep1 p = sepBy1 p $ symbol "," - ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',- '\EM','\FS','\GS','\RS','\US','\SP']- ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',- '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',- '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']+parseLit = lexeme $ charLiteral <|> stringLiteral <|> natFloat+ where+ charLiteral = LChar <$> between (char '\'')+ (char '\'' <?> "end of character")+ (char '\\' *> escapeCode <|> satisfy (\c -> c > '\026' && c /= '\'') <?> "literal character")+ <?> "character" + stringLiteral = between (char '"')+ (char '"' <?> "end of string")+ (LString . concat <$> many stringChar)+ <?> "literal string" - ------------------------------------------------------------ -- Numbers- -----------------------------------------------------------+ stringChar = char '\\' *> stringEscape <|> (:[]) <$> satisfy (\c -> c > '\026' && c /= '"') <?> "string character" - -- floats- natFloat = do{ char '0'- ; zeroNumFloat- }- <|> decimalFloat+ stringEscape = [] <$ some simpleSpace <* (char '\\' <?> "end of string gap")+ <|> [] <$ char '&'+ <|> (:[]) <$> escapeCode - zeroNumFloat = do{ n <- hexadecimal <|> octal- ; return (LInt n)- }- <|> decimalFloat- <|> fractFloat 0- <|> return (LInt 0)+ -- escape codes+ escapeCode = charEsc <|> charNum <|> charAscii <|> char '^' *> charControl <?> "escape code" - decimalFloat = do{ n <- decimal- ; option (LInt n)- (fractFloat n)- }+ charControl = toEnum . (+ (- fromEnum 'A')) . fromEnum <$> satisfy isUpper <?> "uppercase letter" - fractFloat n = do{ f <- fractExponent n- ; return (LFloat f)- }+ charNum = toEnum . fromInteger <$> (decimal <|> char 'o' *> octal <|> char 'x' *> hexadecimal) - fractExponent n = do{ fract <- fraction- ; expo <- option 1.0 exponent'- ; return ((fromInteger n + fract)*expo)- }- <|>- do{ expo <- exponent'- ; return ((fromInteger n)*expo)- }+ charEsc = choice $ zipWith (<$) "\a\b\f\n\r\t\v\\\"\'" $ map char "abfnrtv\\\"\'" - fraction = do{ char '.'- ; digits <- some digit <?> "fraction"- ; return (foldr op 0.0 digits)- }- <?> "fraction"- where- op d f = (f + fromIntegral (digitToInt d))/10.0+ charAscii = choice $ zipWith (<$) ascii $ map (try . string) $ asciicodes - exponent' = do{ oneOf "eE"- ; f <- sign- ; e <- decimal <?> "exponent"- ; return (power (f e))- }- <?> "exponent"- where- power e | e < 0 = 1.0/power(-e)- | otherwise = fromInteger (10^e)+ -- escape code tables+ asciicodes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM"+ ,"FS","GS","RS","US","SP"+ ,"NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL"+ ,"DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB"+ ,"CAN","SUB","ESC","DEL"] + ascii = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI'+ ,'\EM','\FS','\GS','\RS','\US','\SP'+ ,'\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK'+ ,'\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK'+ ,'\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] - -- integers and naturals- sign = (char '-' >> return negate)- <|> (char '+' >> return id)- <|> return id - decimal = number 10 digit- hexadecimal = do{ oneOf "xX"; number 16 hexDigit }- octal = do{ oneOf "oO"; number 8 octDigit }-- number base baseDigit- = do{ digits <- some baseDigit- ; let n = foldl' (\x d -> base*x + toInteger (digitToInt d)) 0 digits- ; seq n (return n)- }---------------------------------------------------------------- Operators & reserved ops-------------------------------------------------------------reservedOp name =- lexeme $ try $- do{ string name- ; notFollowedBy opLetter <?> ("end of " ++ show name)- }--operator oper =- lexeme $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper- where- trCons ":" = "Cons"- trCons x = x--theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"]--expect msg p i = i >>= \n -> if (p n) then unexpected (msg ++ " " ++ show n) else return n---------------------------------------------------------------- Identifiers & Reserved words-------------------------------------------------------------reserved name =- lexeme $ try $- do{ string name- ; notFollowedBy identLetter <?> ("end of " ++ show name)- }--identifier ident =- lexeme $ try $ expect "reserved word" (`Set.member` theReservedNames) ident--theReservedNames = Set.fromList $- ["let","in","case","of","if","then","else"- ,"data","type"- ,"class","default","deriving","do","import"- ,"infix","infixl","infixr","instance","module"- ,"newtype","where"- ,"primitive"- -- "as","qualified","hiding"- ] ++- ["foreign","import","export","primitive"- ,"_ccall_","_casm_"- ,"forall"- ]---------------------------------------------------------------- White space & symbols------------------------------------------------------------+ natFloat = char '0' *> zeroNumFloat <|> decimalFloat -symbol name- = lexeme (string name)+ zeroNumFloat = LInt <$> (oneOf "xX" *> hexadecimal <|> oneOf "oO" *> octal)+ <|> decimalFloat+ <|> fractFloat 0+ <|> return (LInt 0) -whiteSpace' = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")+ decimalFloat = decimal >>= \n -> option (LInt n) (fractFloat n) -simpleSpace- = skipSome (satisfy isSpace)+ fractFloat n = LFloat <$> fractExponent (fromInteger n) -oneLineComment- = try (string "--" >> many (char '-') >> notFollowedBy opLetter)- >> skipMany (satisfy (/= '\n'))+ fractExponent n = (*) <$> ((n +) <$> fraction) <*> option 1.0 exponent'+ <|> (n *) <$> exponent' -multiLineComment = try (string "{-") *> inCommentMulti+ fraction = foldr op 0.0 <$ char '.' <*> some digitChar <?> "fraction"+ where+ op d f = (f + fromIntegral (digitToInt d))/10.0 -inCommentMulti- = try (() <$ string "-}")- <|> multiLineComment *> inCommentMulti- <|> skipSome (noneOf "{}-") *> inCommentMulti- <|> oneOf "{}-" *> inCommentMulti- <?> "end of comment"+ exponent' = (10^^) <$ oneOf "eE" <*> ((negate <$ char '-' <|> id <$ char '+' <|> return id) <*> decimal) <?> "exponent"
src/LambdaCube/Compiler/Parser.hs view
@@ -13,14 +13,13 @@ , sourceInfo, SI(..), debugSI , Module(..), Visibility(..), Binder(..), SExp'(..), Extension(..), Extensions , pattern SVar, pattern SType, pattern Wildcard, pattern SAppV, pattern SLamV, pattern SAnn- , pattern SBuiltin, pattern SPi, pattern Primitive, pattern SLabelEnd, pattern SLam+ , pattern SBuiltin, pattern SPi, pattern Primitive, pattern SLabelEnd, pattern SLam, pattern Parens , pattern TyType, pattern Wildcard_- , debug, LI, isPi, varDB, lowerDB, MaxDB (..), iterateN, traceD, parseLC+ , debug, isPi, varDB, lowerDB, upDB, cmpDB, MaxDB(..), iterateN, traceD+ , parseLC, runDefParser , getParamsS, addParamsS, getApps, apps', downToS, addForalls- , mkDesugarInfo, joinDesugarInfo- , throwErrorTCM, ErrorMsg(..), ErrorT , Up (..), up1, up- , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr+ , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr, shTuple , mtrace, sortDefs , trSExp', usedS, substSG0, substS , Stmt (..), Export (..), ImportItems (..)@@ -59,14 +58,6 @@ instance Eq (SData a) where _ == _ = True instance Ord (SData a) where _ `compare` _ = EQ -newtype ErrorMsg = ErrorMsg String-instance Show ErrorMsg where show (ErrorMsg s) = s--type ErrorT = ExceptT ErrorMsg--throwErrorTCM :: MonadError ErrorMsg m => P.Doc -> m a-throwErrorTCM d = throwError $ ErrorMsg $ show d- traceD x = if debug then trace_ x else id debug = False--True--tr@@ -102,15 +93,12 @@ = SGlobal SIName | SBind SI Binder (SData SIName{-parameter's name-}) (SExp' a) (SExp' a) | SApp SI Visibility (SExp' a) (SExp' a)- | SLet LI (SExp' a) (SExp' a) -- let x = e in f --> SLet e f{-x is Var 0-}+ | SLet SIName (SExp' a) (SExp' a) -- let x = e in f --> SLet e f{-x is Var 0-} | SVar_ (SData SIName) !Int | SLit SI Lit | STyped SI a deriving (Eq, Show) --- let info-type LI = (Bool, SIName, SData (Maybe Fixity), [Visibility])- pattern SVar a b = SVar_ (SData a) b data Binder@@ -142,6 +130,7 @@ pattern SBuiltin s <- SGlobal (_, s) where SBuiltin s = SGlobal (debugSI $ "builtin " ++ s, s) pattern Section e = SBuiltin "^section" `SAppV` e+pattern Parens e = SBuiltin "parens" `SAppV` e sApp v a b = SApp (sourceInfo a <> sourceInfo b) v a b sBind v x a b = SBind (sourceInfo a <> sourceInfo b) v x a b@@ -162,9 +151,8 @@ run (SApp _ h a b) = second ((h, b):) $ run a run x = (x, []) -downToS n m = map (SVar (debugSI "20", ".ds")) [n+m-1, n+m-2..n]--xSLabelEnd = id --SLabelEnd+-- todo: remove+downToS err n m = [SVar (debugSI $ err ++ " " ++ show i, ".ds") (n + i) | i <- [m-1, m-2..0]] instance SourceInfo (SExp' a) where sourceInfo = \case@@ -186,21 +174,60 @@ SGlobal (_, n) -> SGlobal (si, n) SLit _ l -> SLit si l --------------------------------------------------------------------------------- low-level toolbox+-------------------------------------------------------------------------------- De-Bruijn limit -newtype MaxDB = MaxDB {getMaxDB :: Maybe Int}+newtype MaxDB = MaxDB {getMaxDB :: Int} -- True: closed instance Monoid MaxDB where- mempty = MaxDB Nothing- MaxDB a `mappend` MaxDB a' = MaxDB $ Just $ max (fromMaybe 0 a) (fromMaybe 0 a')+ mempty = MaxDB 0+ MaxDB a `mappend` MaxDB a' = MaxDB $ max a a'+ where+ max 0 x = x+ max _ _ = 1 -- instance Show MaxDB where show _ = "MaxDB" -varDB i = MaxDB $ Just $ i + 1+varDB i = MaxDB 1 -- -lowerDB (MaxDB i) = MaxDB $ (+ (- 1)) <$> i---lowerDB' l (MaxDB i) = MaxDB $ Just $ 1 + max l (fromMaybe 0 i)+lowerDB = id -- +cmpDB _ (maxDB_ -> MaxDB x) = x == 0++upDB _ (MaxDB 0) = MaxDB 0+upDB x (MaxDB i) = MaxDB $ x + i+{-+data Na = Ze | Su Na++newtype MaxDB = MaxDB {getMaxDB :: Na} -- True: closed++instance Monoid MaxDB where+ mempty = MaxDB Ze+ MaxDB a `mappend` MaxDB a' = MaxDB $ max a a'+ where+ max Ze x = x+ max (Su i) x = Su $ case x of+ Ze -> i+ Su j -> max i j++instance Show MaxDB where show _ = "MaxDB"++varDB i = MaxDB $ Su $ fr i+ where+ fr 0 = Ze+ fr i = Su $ fr $ i-1++lowerDB (MaxDB Ze) = MaxDB Ze+lowerDB (MaxDB (Su i)) = MaxDB i++cmpDB _ (maxDB_ -> MaxDB x) = case x of Ze -> True; _ -> False -- == 0++upDB _ (MaxDB Ze) = MaxDB Ze+upDB x (MaxDB i) = MaxDB $ ad x i where+ ad 0 i = i+ ad n i = Su $ ad (n-1) i+-}+-------------------------------------------------------------------------------- low-level toolbox+ class Up a where up_ :: Int -> Int -> a -> a up_ n i = iterateN n $ up1_ i@@ -220,7 +247,7 @@ instance (Up a, Up b) => Up (a, b) where up_ n i (a, b) = (up_ n i a, up_ n i b) used i (a, b) = used i a || used i b- fold _ _ _ = error "fold @(_,_)"+ fold f i (a, b) = fold f i a <> fold f i b maxDB_ (a, b) = maxDB_ a <> maxDB_ b closedExp (a, b) = (closedExp a, closedExp b) @@ -280,8 +307,11 @@ maxDB_ _ = error "maxDB @Void" instance Up a => Up (SExp' a) where- up_ n i = mapS' (\sn j i -> SVar sn $ if j < i then j else j+n) (+1) i- fold f = foldS (\_ _ _ -> error "fold @SExp") mempty $ \sn j i -> f j i+ up_ n = mapS' (\sn j i -> SVar sn $ if j < i then j else j+n) (+1)+ where+ mapS' = mapS__ (\i si x -> STyped si $ up_ n i x) (const . SGlobal)++ fold f = foldS (\i si x -> fold f i x) mempty $ \sn j i -> f j i maxDB_ _ = error "maxDB @SExp" dbf' = dbf_ 0@@ -309,31 +339,33 @@ -------------------------------------------------------------------------------- expression parsing parseType mb = maybe id option mb (reservedOp "::" *> parseTTerm PrecLam)-typedIds mb = (,) <$> commaSep1 (parseSIName upperLower) <*> indented {-TODO-} (parseType mb)+typedIds mb = (,) <$> commaSep1 upperLower <*> parseType mb hiddenTerm p q = (,) Hidden <$ reservedOp "@" <*> p <|> (,) Visible <$> q telescope mb = fmap dbfi $ many $ hiddenTerm (typedId <|> maybe empty (tvar . pure) mb)- (try "::" typedId <|> maybe ((,) <$> parseSIName (pure "") <*> parseTTerm PrecAtom) (tvar . pure) mb)+ (try "::" typedId <|> maybe ((,) <$> pure (mempty, "") <*> parseTTerm PrecAtom) (tvar . pure) mb) where- tvar x = (,) <$> parseSIName patVar <*> x- typedId = parens $ tvar $ indented {-TODO-} (parseType mb)+ tvar x = (,) <$> patVar <*> x+ typedId = parens $ tvar $ parseType mb dbfi = first reverse . unzip . go [] where go _ [] = [] go vs ((v, (n, e)): ts) = (n, (v, dbf' vs e)): go (n: vs) ts -sVar = withRange $ curry SGlobal- parseTTerm = typeNS . parseTerm parseETerm = expNS . parseTerm -indentation p q = p >> indented q+indentation p q = p >> q -parseTerm :: Prec -> P SExp-parseTerm prec = withRange setSI $ case prec of+setSI' p = appRange $ flip setSI <$> p++parseTerm = setSI' . parseTerm_++parseTerm_ :: Prec -> P SExp+parseTerm_ prec = case prec of PrecLam -> do level PrecAnn $ \t -> mkPi <$> (Visible <$ reservedOp "->" <|> Hidden <$ reservedOp "=>") <*> pure t <*> parseTTerm PrecLam <|> mkIf <$ reserved "if" <*> parseTerm PrecLam <* reserved "then" <*> parseTerm PrecLam <* reserved "else" <*> parseTerm PrecLam@@ -348,8 +380,8 @@ t' <- dbf' fe <$> parseTerm PrecLam ge <- dsInfo return $ foldr (uncurry (patLam id ge)) t' ts- <|> compileCase <$ reserved "case" <*> dsInfo <*> parseETerm PrecLam <*> do- indentSome "of" $ do+ <|> compileCase <$ reserved "case" <*> dsInfo <*> parseETerm PrecLam <* reserved "of" <*> do+ indentMS False $ do (fe, p) <- longPattern (,) p <$> parseRHS (dbf' fe) "->" -- <|> compileGuardTree id id <$> dsInfo <*> (Alts <$> parseSomeGuards (const True))@@ -358,28 +390,32 @@ notExp = (++) <$> ope <*> notOp True notOp x = (++) <$> try "expression" ((++) <$> ex PrecApp <*> option [] ope) <*> notOp True <|> if x then option [] (try "lambda" $ ex PrecLam) else mzero- ope = pure . Left <$> parseSIName (rhsOperator <|> "'EqCTt" <$ reservedOp "~")+ ope = pure . Left <$> (rhsOperator <|> psn ("'EqCTt" <$ reservedOp "~")) ex pr = pure . Right <$> parseTerm pr PrecApp ->- apps' <$> try "record" (sVar upperCase <* reservedOp "{") <*> (commaSep $ lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* reservedOp "}"+ apps' <$> try "record" ((SGlobal <$> upperCase) <* symbol "{") <*> commaSep (lowerCase *> reservedOp "=" *> ((,) Visible <$> parseTerm PrecLam)) <* symbol "}" <|> apps' <$> parseTerm PrecSwiz <*> many (hiddenTerm (parseTTerm PrecSwiz) $ parseTerm PrecSwiz) PrecSwiz -> level PrecProj $ \t -> mkSwizzling t <$> lexeme (try "swizzling" $ char '%' *> manyNM 1 4 (satisfy (`elem` ("xyzwrgba" :: String))))- PrecProj -> level PrecAtom $ \t -> try "projection" $ mkProjection t <$ char '.' <*> sepBy1 (sLit . LString <$> lowerCase) (char '.')+ PrecProj -> level PrecAtom $ \t -> try "projection" $ mkProjection t <$ char '.' <*> sepBy1 (uncurry SLit . second LString <$> lowerCase) (char '.') PrecAtom -> mkLit <$> try "literal" parseLit <|> Wildcard (Wildcard SType) <$ reserved "_"- <|> char '\'' *> switchNS (parseTerm PrecAtom)- <|> sVar (try "identifier" upperLower)- <|> brackets ( (parseTerm PrecLam >>= \e ->+ <|> mkLets <$ reserved "let" <*> dsInfo <*> parseDefs <* reserved "in" <*> parseTerm PrecLam+ <|> SGlobal <$> lowerCase+ <|> SGlobal <$> upperCase_ -- todo: move under ppa?+ <|> braces (mkRecord <$> commaSep ((,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam))+ <|> char '\'' *> ppa switchNamespace+ <|> ppa id+ where+ level pr f = parseTerm_ pr >>= \t -> option t $ f t++ ppa tick =+ brackets ( (parseTerm PrecLam >>= \e -> mkDotDot e <$ reservedOp ".." <*> parseTerm PrecLam <|> foldr ($) (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil") <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression)- <|> mkList <$> namespace <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam)))- ) <|> mkList <$> namespace <*> pure [])- <|> mkTuple <$> namespace <*> parens (commaSep $ parseTerm PrecLam)- <|> mkRecord <$> braces (commaSep $ (,) <$> lowerCase <* symbol ":" <*> parseTerm PrecLam)- <|> mkLets True <$> dsInfo <*> parseDefs xSLabelEnd (indentMany "let") <* reserved "in" <*> parseTerm PrecLam- where- level pr f = parseTerm pr >>= \t -> option t $ f t+ <|> mkList . tick <$> namespace <*> ((e:) <$> option [] (symbol "," *> commaSep1 (parseTerm PrecLam)))+ ) <|> mkList . tick <$> namespace <*> pure [])+ <|> parens (SGlobal <$> try "opname" (symbols <* lookAhead (symbol ")")) <|> mkTuple . tick <$> namespace <*> commaSep (parseTerm PrecLam)) mkSwizzling term = swizzcall where@@ -399,29 +435,27 @@ mkProjection = foldl $ \exp field -> SBuiltin "project" `SAppV` field `SAppV` exp - -- Creates: RecordCons @[("x", _), ("y", _), ("z", _)] (1.0, (2.0, (3.0, ())))+ -- Creates: RecordCons @[("x", _), ("y", _), ("z", _)] (1.0, 2.0, 3.0))) mkRecord xs = SBuiltin "RecordCons" `SAppH` names `SAppV` values where (names, values) = mkNames *** mkValues $ unzip xs - mkNameTuple v = SBuiltin "Tuple2" `SAppV` sLit (LString v) `SAppV` Wildcard SType+ mkNameTuple (si, v) = SBuiltin "RecItem" `SAppV` SLit si (LString v) `SAppV` Wildcard SType mkNames = foldr (\n ns -> SBuiltin "Cons" `SAppV` mkNameTuple n `SAppV` ns) (SBuiltin "Nil") - mkValues = foldr (\x xs -> SBuiltin "Tuple2" `SAppV` x `SAppV` xs)- (SBuiltin "Tuple0")+ mkValues = foldr (\x xs -> SBuiltin "HCons" `SAppV` x `SAppV` xs)+ (SBuiltin "HNil") mkTuple _ [Section e] = e- mkTuple _ [x] = x- mkTuple (Namespace level _) xs = foldl SAppV (SBuiltin (tuple ++ show (length xs))) xs- where tuple = case level of- Just TypeLevel -> "'Tuple"- Just ExpLevel -> "Tuple"- _ -> error "mkTuple"+ mkTuple ExpNS [Parens e] = SBuiltin "HCons" `SAppV` e `SAppV` SBuiltin "HNil"+ mkTuple TypeNS [Parens e] = SBuiltin "'HList" `SAppV` (SBuiltin "Cons" `SAppV` e `SAppV` SBuiltin "Nil")+ mkTuple _ [x] = Parens x+ mkTuple ExpNS xs = foldr (\x y -> SBuiltin "HCons" `SAppV` x `SAppV` y) (SBuiltin "HNil") xs+ mkTuple TypeNS xs = SBuiltin "'HList" `SAppV` foldr (\x y -> SBuiltin "Cons" `SAppV` x `SAppV` y) (SBuiltin "Nil") xs - mkList (Namespace (Just TypeLevel) _) [x] = SBuiltin "'List" `SAppV` x- mkList (Namespace (Just ExpLevel) _) xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs- mkList _ xs = error "mkList"+ mkList TypeNS [x] = SBuiltin "'List" `SAppV` x+ mkList _ xs = foldr (\x l -> SBuiltin "Cons" `SAppV` x `SAppV` l) (SBuiltin "Nil") xs mkLit n@LInt{} = SBuiltin "fromInt" `SAppV` sLit n mkLit l = sLit l@@ -460,7 +494,7 @@ ]) `SAppV` exp - letdecl = mkLets False <$ reserved "let" <*> dsInfo <*> (compileFunAlts' id =<< valueDef)+ letdecl = mkLets <$ reserved "let" <*> dsInfo <*> (compileFunAlts' =<< valueDef) boolExpression = (\pred e -> SBuiltin "primIfThenElse" `SAppV` pred `SAppV` e `SAppV` SBuiltin "Nil") <$> parseTerm PrecLam @@ -470,11 +504,11 @@ sNonDepPi h a b = SPi h a $ up1 b -getTTuple' (getTTuple -> Just (n, xs)) | n == length xs = xs+getTTuple' (SBuiltin "'HList" `SAppV` (getTTuple -> Just (n, xs))) | n == length xs = xs getTTuple' x = [x] -getTTuple (SAppV (getTTuple -> Just (n, xs)) z) = Just (n, xs ++ [z]{-todo: eff-})-getTTuple (SGlobal (si, s@(splitAt 6 -> ("'Tuple", reads -> [(n, "")])))) = Just (n :: Int, [])+getTTuple (SBuiltin "Nil") = Just (0, [])+getTTuple (SBuiltin "Cons" `SAppV` x `SAppV` (getTTuple -> Just (n, y))) = Just (n+1, x:y) getTTuple _ = Nothing patLam :: (SExp -> SExp) -> DesugarInfo -> (Visibility, SExp) -> Pat -> SExp -> SExp@@ -489,6 +523,8 @@ | PatType ParPat SExp deriving Show +pattern PParens p = ViewPat (SBuiltin "parens") (ParPat [p])+ -- parallel patterns like v@(f -> [])@(Just x) newtype ParPat = ParPat [Pat] deriving Show@@ -500,6 +536,7 @@ mapP f = \case PVar n -> PVar n PCon n pp -> PCon n (mapPP f <$> pp)+ PParens p -> PParens (mapP f p) ViewPat e pp -> ViewPat (f e) (mapPP f pp) PatType pp e -> PatType (mapPP f pp) (f e) @@ -518,6 +555,7 @@ getPVars_ = \case PVar n -> [n] PCon _ pp -> foldMap getPPVars_ pp+ PParens p -> getPVars_ p ViewPat e pp -> getPPVars_ pp PatType pp e -> getPPVars_ pp @@ -543,24 +581,24 @@ PrecOp -> calculatePatPrecs <$> dsInfo <*> p_ where- p_ = (,) <$> parsePat PrecApp <*> option [] (parseSIName colonSymbols >>= p)- p op = do (exp, op') <- try "pattern" ((,) <$> parsePat PrecApp <*> parseSIName colonSymbols)+ p_ = (,) <$> parsePat PrecApp <*> option [] (colonSymbols >>= p)+ p op = do (exp, op') <- try "pattern" ((,) <$> parsePat PrecApp <*> colonSymbols) ((op, exp):) <$> p op' <|> pure . (,) op <$> parsePat PrecAnn PrecApp ->- PCon <$> parseSIName upperCase <*> many (ParPat . pure <$> parsePat PrecAtom)+ PCon <$> upperCase_ <*> many (ParPat . pure <$> parsePat PrecAtom) <|> parsePat PrecAtom PrecAtom -> mkLit <$> namespace <*> try "literal" parseLit- <|> flip PCon [] <$> parseSIName upperCase+ <|> flip PCon [] <$> upperCase_ <|> char '\'' *> switchNS (parsePat PrecAtom)- <|> PVar <$> parseSIName patVar+ <|> PVar <$> patVar <|> (\ns -> pConSI . mkListPat ns) <$> namespace <*> brackets patlist <|> (\ns -> pConSI . mkTupPat ns) <$> namespace <*> parens patlist where litP = flip ViewPat (ParPat [PCon (mempty, "True") []]) . SAppV (SBuiltin "==") - mkLit (Namespace (Just TypeLevel) _) (LInt n) = toNatP n -- todo: elim this alternative+ mkLit TypeNS (LInt n) = toNatP n -- todo: elim this alternative mkLit _ n@LInt{} = litP (SBuiltin "fromInt" `SAppV` sLit n) mkLit _ n = litP (sLit n) @@ -573,14 +611,17 @@ patlist = commaSep $ parsePat PrecAnn - mkListPat ns [p] | namespaceLevel ns == Just TypeLevel = PCon (debugSI "mkListPat4", "'List") [ParPat [p]]+ mkListPat TypeNS [p] = PCon (debugSI "mkListPat4", "'List") [ParPat [p]] mkListPat ns (p: ps) = PCon (debugSI "mkListPat2", "Cons") $ map (ParPat . (:[])) [p, mkListPat ns ps] mkListPat _ [] = PCon (debugSI "mkListPat3", "Nil") [] --mkTupPat :: [Pat] -> Pat- mkTupPat ns [x] = x- mkTupPat ns ps = PCon (debugSI "", tick ns $ "Tuple" ++ show (length ps)) (ParPat . (:[]) <$> ps)+ mkTupPat ns [PParens x] = ff [x]+ mkTupPat ns [x] = PParens x+ mkTupPat ns ps = ff ps + ff ps = foldr (\a b -> PCon (mempty, "HCons") (ParPat . (:[]) <$> [a, b])) (PCon (mempty, "HNil") []) ps+ patType p (Wildcard SType) = p patType p t = PatType (ParPat [p]) t @@ -591,6 +632,7 @@ telescopePat = fmap (getPPVars . ParPat . map snd &&& id) $ many $ uncurry f <$> hiddenTerm (parsePat PrecAtom) (parsePat PrecAtom) where+ f h (PParens p) = second PParens $ f h p f h (PatType (ParPat [p]) t) = ((h, t), p) f h p = ((h, Wildcard SType), p) @@ -637,8 +679,10 @@ ] cp ps' ((p@PVar{}, i): xs) = cp (p: ps') xs cp ps' ((p@(PCon (si, n) ps), i): xs) = GuardNode (SVar (si, n) $ i + sum (map (fromMaybe 0 . ff) ps')) n ps $ cp (p: ps') xs+ cp ps' ((PParens p, i): xs) = cp ps' ((p, i): xs) cp ps' ((p@(ViewPat f (ParPat [PCon (si, n) ps])), i): xs) = GuardNode (SAppV f $ SVar (si, n) $ i + sum (map (fromMaybe 0 . ff) ps')) n ps $ cp (p: ps') xs+ cp _ p = error $ "cp: " ++ show p m = length ps @@ -659,8 +703,8 @@ vs' = map (fromMaybe 0) vs_ s = sum vs -compileGuardTrees False ulend lend ge alts = compileGuardTree ulend lend ge $ Alts alts-compileGuardTrees True ulend lend ge alts = foldr1 (SAppV2 $ SBuiltin "parEval" `SAppV` Wildcard SType) $ compileGuardTree ulend lend ge <$> alts+compileGuardTrees ulend ge alts = compileGuardTree ulend SLabelEnd ge $ Alts alts+compileGuardTrees' ge alts = foldr1 (SAppV2 $ SBuiltin "parEval" `SAppV` Wildcard SType) $ compileGuardTree id SLabelEnd ge <$> alts compileGuardTree :: (SExp -> SExp) -> (SExp -> SExp) -> DesugarInfo -> GuardTree -> SExp compileGuardTree ulend lend adts t = (\x -> traceD (" ! :" ++ ppShow x) x) $ guardTreeToCases t@@ -671,8 +715,8 @@ GuardLeaf e: _ -> lend e ts@(GuardNode f s _ _: _) -> case Map.lookup s (snd adts) of Nothing -> error $ "Constructor is not defined: " ++ s- Just (Left ((t, inum), cns)) ->- foldl SAppV (SGlobal (debugSI "compileGuardTree2", caseName t) `SAppV` iterateN (1 + inum) SLamV (Wildcard SType))+ Just (Left ((casename, inum), cns)) ->+ foldl SAppV (SGlobal (debugSI "compileGuardTree2", casename) `SAppV` iterateN (1 + inum) SLamV (Wildcard (Wildcard SType))) [ iterateN n SLamV $ guardTreeToCases $ Alts $ map (filterGuardTree (up n f) cn 0 n . upGT 0 n) ts | (cn, n) <- cns ]@@ -714,8 +758,9 @@ guardNode v [] e = e guardNode v [w] e = case w of PVar _ -> {-todo guardNode v (subst x v ws) $ -} varGuardNode 0 v e- ViewPat f (ParPat p) -> guardNode (f `SAppV` v) p {- $ guardNode v ws -} e- PCon (_, s) ps' -> GuardNode v s ps' {- $ guardNode v ws -} e+ PParens p -> guardNode v [p] e+ ViewPat f (ParPat p) -> guardNode (f `SAppV` v) p {- -$ guardNode v ws -} e+ PCon (_, s) ps' -> GuardNode v s ps' {- -$ guardNode v ws -} e varGuardNode v (SVar _ e) = substGT v e @@ -726,7 +771,7 @@ -------------------------------------------------------------------------------- declaration representation data Stmt- = Let SIName MFixity (Maybe SExp) [Visibility]{-source arity-} SExp+ = Let SIName (Maybe SExp) SExp | Data SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} Bool{-True:add foralls-} [(SIName, SExp)]{-constructor names and types-} | PrecDef SIName Fixity @@ -738,23 +783,23 @@ | FunAlt SIName [((Visibility, SExp), Pat)] (Either [(SExp, SExp)]{-guards-} SExp{-no guards-}) deriving (Show) -pattern Primitive n mf t <- Let n mf (Just t) _ (SBuiltin "undefined") where Primitive n mf t = Let n mf (Just t) (map fst $ fst $ getParamsS t) $ SBuiltin "undefined"+pattern Primitive n t <- Let n (Just t) (SBuiltin "undefined") where Primitive n t = Let n (Just t) $ SBuiltin "undefined" -------------------------------------------------------------------------------- declaration parsing parseDef :: P [Stmt] parseDef =- do indentation (reserved "data") $ do- x <- typeNS $ parseSIName upperCase+ do reserved "data" *> do+ x <- typeNS upperCase (npsd, ts) <- telescope (Just SType) t <- dbf' npsd <$> parseType (Just SType) let mkConTy mk (nps', ts') = ( if mk then Just nps' else Nothing- , foldr (uncurry SPi) (foldl SAppV (SGlobal x) $ downToS (length ts') $ length ts) ts')+ , foldr (uncurry SPi) (foldl SAppV (SGlobal x) $ downToS "a1" (length ts') $ length ts) ts') (af, cs) <- option (True, []) $- do fmap ((,) True) $ indentMany "where" $ second ((,) Nothing . dbf' npsd) <$> typedIds Nothing+ do fmap ((,) True) $ (reserved "where" >>) $ indentMS True $ second ((,) Nothing . dbf' npsd) <$> typedIds Nothing <|> (,) False <$ reservedOp "=" <*>- sepBy1 ((,) <$> (pure <$> parseSIName upperCase)+ sepBy1 ((,) <$> (pure <$> upperCase) <*> do do braces $ mkConTy True . second (zipWith (\i (v, e) -> (v, dbf_ i npsd e)) [0..]) <$> telescopeDataFields <|> mkConTy False . second (zipWith (\i (v, e) -> (v, dbf_ i npsd e)) [0..])@@ -762,32 +807,32 @@ ) (reservedOp "|") mkData <$> dsInfo <*> pure x <*> pure ts <*> pure t <*> pure af <*> pure (concatMap (\(vs, t) -> (,) <$> vs <*> pure t) cs)- <|> do indentation (reserved "class") $ do- x <- parseSIName $ typeNS upperCase+ <|> do reserved "class" *> do+ x <- typeNS upperCase (nps, ts) <- telescope (Just SType)- cs <- option [] $ indentMany "where" $ typedIds Nothing+ cs <- option [] $ (reserved "where" >>) $ indentMS True $ typedIds Nothing return $ pure $ Class x (map snd ts) (concatMap (\(vs, t) -> (,) <$> vs <*> pure (dbf' nps t)) cs) <|> do indentation (reserved "instance") $ typeNS $ do constraints <- option [] $ try "constraint" $ getTTuple' <$> parseTerm PrecOp <* reservedOp "=>"- x <- parseSIName upperCase+ x <- upperCase (nps, args) <- telescopePat- checkPattern nps- cs <- expNS $ option [] $ indentSome "where" $ dbFunAlt nps <$> funAltDef varId- pure . Instance x ({-todo-}map snd args) (dbff (nps <> [x]) <$> constraints) <$> compileFunAlts' id{-TODO-} cs+ checkPattern nps + cs <- expNS $ option [] $ reserved "where" *> indentMS False (dbFunAlt nps <$> funAltDef varId)+ pure . Instance x ({-todo-}map snd args) (dbff (nps <> [x]) <$> constraints) <$> compileFunAlts' cs <|> do indentation (try "type family" $ reserved "type" >> reserved "family") $ typeNS $ do- x <- parseSIName upperCase+ x <- upperCase (nps, ts) <- telescope (Just SType) t <- dbf' nps <$> parseType (Just SType) option {-open type family-}[TypeFamily x ts t] $ do- cs <- indentMany "where" $ funAltDef $ mfilter (== snd x) upperCase+ cs <- (reserved "where" >>) $ indentMS True $ funAltDef $ mfilter (== x) upperCase -- closed type family desugared here- compileFunAlts False id SLabelEnd [TypeAnn x $ addParamsS ts t] cs+ compileFunAlts (compileGuardTrees id) [TypeAnn x $ addParamsS ts t] cs <|> do indentation (try "type instance" $ reserved "type" >> reserved "instance") $ typeNS $ pure <$> funAltDef upperCase <|> do indentation (reserved "type") $ typeNS $ do- x <- parseSIName upperCase+ x <- upperCase (nps, ts) <- telescope $ Just (Wildcard SType) rhs <- dbf' nps <$ reservedOp "=" <*> parseTerm PrecLam- compileFunAlts False id SLabelEnd+ compileFunAlts (compileGuardTrees id) [{-TypeAnn x $ addParamsS ts $ SType-}{-todo-}] [FunAlt x (zip ts $ map PVar $ reverse nps) $ Right rhs] <|> do try "typed ident" $ (\(vs, t) -> TypeAnn <$> vs <*> pure t) <$> typedIds Nothing@@ -796,7 +841,7 @@ <|> valueDef where telescopeDataFields :: P ([SIName], [(Visibility, SExp)]) - telescopeDataFields = dbfi <$> commaSep ((,) Visible <$> ((,) <$> parseSIName lowerCase <*> parseType Nothing))+ telescopeDataFields = dbfi <$> commaSep ((,) Visible <$> ((,) <$> lowerCase <*> parseType Nothing)) mkData ge x ts t af cs = Data x ts t af (second snd <$> cs): concatMap mkProj (nub $ concat [fs | (_, (Just fs, _)) <- cs]) where@@ -806,28 +851,27 @@ ] -parseRHS fe tok = fmap (fmap (fe *** fe) +++ fe) $ indented $ do+parseRHS fe tok = fmap (fmap (fe *** fe) +++ fe) $ do fmap Left . some $ (,) <$ reservedOp "|" <*> parseTerm PrecOp <* reservedOp tok <*> parseTerm PrecLam <|> do reservedOp tok rhs <- parseTerm PrecLam- f <- option id $ mkLets True <$> dsInfo <*> parseDefs xSLabelEnd (indentMany "where")+ f <- option id $ mkLets <$ reserved "where" <*> dsInfo <*> parseDefs return $ Right $ f rhs -parseDefs lend p = p parseDef >>= compileFunAlts' lend . concat+parseDefs = indentMS True parseDef >>= compileFunAlts' . concat funAltDef parseName = do -- todo: use ns to determine parseName (n, (fee, tss)) <- do try "operator definition" $ do (e', a1) <- longPattern- indented $ do- n <- parseSIName lhsOperator- (e'', a2) <- longPattern- lookAhead $ reservedOp "=" <|> reservedOp "|"- return (n, (e'' <> e', (,) (Visible, Wildcard SType) <$> [a1, mapP (dbf' e') a2]))+ n <- lhsOperator+ (e'', a2) <- longPattern+ lookAhead $ reservedOp "=" <|> reservedOp "|"+ return (n, (e'' <> e', (,) (Visible, Wildcard SType) <$> [a1, mapP (dbf' e') a2])) <|> do try "lhs" $ do- n <- parseSIName parseName- indented $ (,) n <$> telescopePat <* lookAhead (reservedOp "=" <|> reservedOp "|")+ n <- parseName+ (,) n <$> telescopePat <* lookAhead (reservedOp "=" <|> reservedOp "|") checkPattern fee FunAlt n tss <$> parseRHS (dbf' fee) "=" @@ -835,7 +879,7 @@ valueDef = do (dns, p) <- try "pattern" $ longPattern <* reservedOp "=" checkPattern dns- e <- indented $ parseETerm PrecLam+ e <- parseETerm PrecLam ds <- dsInfo return $ desugarValueDef ds p e @@ -863,17 +907,17 @@ f <$> ((map (dbfGT e') <$> parseSomeGuards (> pos)) <|> (:[]) . GuardLeaf <$ reservedOp "->" <*> (dbf' e' <$> parseETerm PrecLam)) <*> option [] (parseSomeGuards (== pos)) -}-mkLets :: Bool -> DesugarInfo -> [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-}-mkLets a ds = mkLets' a ds . sortDefs ds where- mkLets' _ _ [] e = e- mkLets' False ge (Let n _ mt ar x: ds) e | not $ usedS n x- = SLet (False, n, SData Nothing, ar) (maybe id (flip SAnn . addForalls {-todo-}[] []) mt x) (substSG0 n $ mkLets' False ge ds e)- mkLets' True ge (Let n _ mt ar x: ds) e | not $ usedS n x- = SLet (False, n, SData Nothing, ar) (maybe id (flip SAnn . addForalls {-todo-}[] []) mt x) (substSG0 n $ mkLets' True ge ds e)- mkLets' _ _ (x: ds) e = error $ "mkLets: " ++ show x+mkLets :: DesugarInfo -> [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-}+mkLets ds = mkLets' . sortDefs ds where+ mkLets' [] e = e+ mkLets' (Let n mt x: ds) e+ = SLet n (maybe id (flip SAnn . addForalls {-todo-}[] []) mt x') (substSG0 n $ mkLets' ds e)+ where+ x' = if usedS n x then SBuiltin "primFix" `SAppV` SLamV (substSG0 n x) else x+ mkLets' (x: ds) e = error $ "mkLets: " ++ show x addForalls :: Up a => Extensions -> [SName] -> SExp' a -> SExp' a-addForalls exs defined x = foldl f x [v | v@(_, vh:_) <- reverse $ freeS x, snd v `notElem'` ("fromInt"{-todo: remove-}: defined), isLower vh || NoConstructorNamespace `elem` exs]+addForalls exs defined x = foldl f x [v | v@(_, vh:_) <- reverse $ freeS x, snd v `notElem'` ("fromInt"{-todo: remove-}: defined), isLower vh] where f e v = SPi Hidden (Wildcard SType) $ substSG0 v e @@ -896,11 +940,11 @@ nodes = zip (zip [0..] xs) $ map (def &&& need) xs need = \case PrecDef{} -> mempty- Let _ _ mt _ e -> foldMap freeS' mt <> freeS' e+ Let _ mt e -> foldMap freeS' mt <> freeS' e Data _ ps t _ cs -> foldMap (freeS' . snd) ps <> freeS' t <> foldMap (freeS' . snd) cs def = \case PrecDef{} -> mempty- Let n _ _ _ _ -> Set.singleton n+ Let n _ _ -> Set.singleton n Data n _ _ _ cs -> Set.singleton n <> Set.fromList (map fst cs) freeS' = Set.fromList . freeS topSort acc@(_:_) defs vs xs | Set.null vs = reverse acc: topSort mempty defs vs xs@@ -928,32 +972,36 @@ -} -compileFunAlts' lend ds = fmap concat . sequence $ map (compileFunAlts False lend lend ds) $ groupBy h ds where+compileFunAlts' ds = fmap concat . sequence $ map (compileFunAlts (compileGuardTrees SLabelEnd) ds) $ groupBy h ds where h (FunAlt n _ _) (FunAlt m _ _) = m == n h _ _ = False --compileFunAlts :: forall m . Monad m => Bool -> (SExp -> SExp) -> (SExp -> SExp) -> DesugarInfo -> [Stmt] -> [Stmt] -> m [Stmt]-compileFunAlts par ulend lend ds xs = dsInfo >>= \ge -> case xs of+compileFunAlts compilegt ds xs = dsInfo >>= \ge -> case xs of [Instance{}] -> return []- [Class n ps ms] -> compileFunAlts' SLabelEnd $+ [Class n ps ms] -> do+ cd <- compileFunAlts' $ [ TypeAnn n $ foldr (SPi Visible) SType ps ] ++ [ FunAlt n (map noTA ps) $ Right $ foldr (SAppV2 $ SBuiltin "'T2") (SBuiltin "'Unit") cstrs | Instance n' ps cstrs _ <- ds, n == n' ] ++ [ FunAlt n (replicate (length ps) (noTA $ PVar (debugSI "compileFunAlts1", "generated_name0"))) $ Right $ SBuiltin "'Empty" `SAppV` sLit (LString $ "no instance of " ++ snd n ++ " on ???")]- ++ concat- [ TypeAnn m (addParamsS (map ((,) Hidden) ps) $ SPi Hidden (foldl SAppV (SGlobal n) $ downToS 0 $ length ps) $ up1 t)- : [ FunAlt m p $ Right {- $ SLam Hidden (Wildcard SType) $ up1 -} e- | Instance n' i cstrs alts <- ds, n' == n- , Let m' ~Nothing ~Nothing ar e <- alts, m' == m- , let p = zip ((,) Hidden <$> ps) i -- ++ ((Hidden, Wildcard SType), PVar): []--- , let ic = sum $ map varP i- ]+ cds <- sequence+ [ compileFunAlts'+ $ TypeAnn m (addParamsS (map ((,) Hidden) ps) $ SPi Hidden (foldl SAppV (SGlobal n) $ downToS "a2" 0 $ length ps) $ up1 t)+ : as | (m, t) <- ms -- , let ts = fst $ getParamsS $ up1 t+ , let as = [ FunAlt m p $ Right {- -$ SLam Hidden (Wildcard SType) $ up1 -} $ SLet m' e $ SVar mempty 0+ | Instance n' i cstrs alts <- ds, n' == n+ , Let m' ~Nothing e <- alts, m' == m+ , let p = zip ((,) Hidden <$> ps) i ++ [((Hidden, Wildcard SType), PVar (mempty, ""))]+ -- , let ic = sum $ map varP i+ ] ]- [TypeAnn n t] -> return [Primitive n Nothing t | snd n `notElem` [n' | FunAlt (_, n') _ _ <- ds]]+ return $ cd ++ concat cds+ [TypeAnn n t] -> return [Primitive n t | snd n `notElem` [n' | FunAlt (_, n') _ _ <- ds]] tf@[TypeFamily n ps t] -> case [d | d@(FunAlt n' _ _) <- ds, n' == n] of- [] -> return [Primitive n Nothing $ addParamsS ps t]- alts -> compileFunAlts True id SLabelEnd [TypeAnn n $ addParamsS ps t] alts+ [] -> return [Primitive n $ addParamsS ps t]+ alts -> compileFunAlts compileGuardTrees' [TypeAnn n $ addParamsS ps t] alts [p@PrecDef{}] -> return [p] fs@(FunAlt n vs _: _) -> case map head $ group [length vs | FunAlt _ vs _ <- fs] of [num]@@ -961,13 +1009,11 @@ | n `elem` [n' | TypeFamily n' _ _ <- ds] -> return [] | otherwise -> return [ Let n- (listToMaybe [t | PrecDef n' t <- ds, n' == n]) (listToMaybe [t | TypeAnn n' t <- ds, n' == n])- (map (fst . fst) vs)- (foldr (uncurry SLam . fst) (compileGuardTrees par ulend lend ge+ $ foldr (uncurry SLam . fst) (compilegt ge [ compilePatts (zip (map snd vs) $ reverse [0.. num - 1]) gsx | FunAlt _ vs gsx <- fs- ]) vs)+ ]) vs ] _ -> fail $ "different number of arguments of " ++ snd n ++ " at " ++ ppShow (fst n) x -> return x@@ -983,18 +1029,21 @@ mkDesugarInfo ss = ( Map.fromList $ ("'EqCTt", (Infix, -1)): [(s, f) | PrecDef (_, s) f <- ss] , Map.fromList $- [(cn, Left ((t, pars ty), (snd *** pars) <$> cs)) | Data (_, t) ps ty _ cs <- ss, ((_, cn), ct) <- cs]- ++ [(t, Right $ pars $ addParamsS ps ty) | Data (_, t) ps ty _ cs <- ss]+ [hackHList (cn, Left ((caseName t, pars ty), (snd *** pars) <$> cs)) | Data (_, t) ps ty _ cs <- ss, ((_, cn), ct) <- cs]+ ++ [(t, Right $ pars $ addParamsS ps ty) | Data (_, t) ps ty _ _ <- ss]+-- ++ [(t, Right $ length xs) | Let (_, t) _ (Just ty) xs _ <- ss]+ ++ [("'Type", Right 0)] ) where pars ty = length $ filter ((== Visible) . fst) $ fst $ getParamsS ty -- todo -joinDesugarInfo (fm, cm) (fm', cm') = (Map.union fm fm', Map.union cm cm')-+ hackHList ("HCons", _) = ("HCons", Left (("hlistConsCase", -1), [("HCons", 2)]))+ hackHList ("HNil", _) = ("HNil", Left (("hlistNilCase", -1), [("HNil", 0)]))+ hackHList x = x -------------------------------------------------------------------------------- module exports -data Export = ExportModule SName | ExportId SName+data Export = ExportModule SIName | ExportId SIName parseExport :: Namespace -> P Export parseExport ns =@@ -1004,8 +1053,8 @@ -------------------------------------------------------------------------------- module imports data ImportItems- = ImportAllBut [SName]- | ImportJust [SName]+ = ImportAllBut [SIName]+ | ImportJust [SIName] importlist = parens $ commaSep upperLower @@ -1015,8 +1064,6 @@ data Extension = NoImplicitPrelude- | NoTypeNamespace- | NoConstructorNamespace | TraceTypeCheck deriving (Enum, Eq, Ord, Show) @@ -1025,7 +1072,7 @@ parseExtensions :: P [Extension] parseExtensions- = try "pragma" (symbol "{-#") *> symbol "LANGUAGE" *> commaSep (lexeme ext) <* symbol "#-}"+ = try "pragma" (symbol "{-#") *> symbol "LANGUAGE" *> commaSep (lexeme ext) <* symbol' simpleSpace "#-}" where ext = do s <- some $ satisfy isAlphaNum@@ -1039,20 +1086,20 @@ data Module = Module { extensions :: Extensions- , moduleImports :: [(SName, ImportItems)]+ , moduleImports :: [(SIName, ImportItems)] , moduleExports :: Maybe [Export]- , definitions :: DesugarInfo -> (Either String [Stmt], [PostponedCheck])- , sourceCode :: String+ , definitions :: DefParser } +type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])+ parseModule :: FilePath -> String -> P Module parseModule f str = do exts <- concat <$> many parseExtensions- let ns = Namespace (if NoTypeNamespace `elem` exts then Nothing else Just ExpLevel) (NoConstructorNamespace `notElem` exts) whiteSpace- header <- optionMaybe $ do+ header <- optional $ do modn <- reserved "module" *> moduleName- exps <- optionMaybe (parens $ commaSep $ parseExport ns)+ exps <- optional (parens $ commaSep $ parseExport ExpNS) reserved "where" return (modn, exps) let mkIDef _ n i h _ = (n, f i h)@@ -1062,29 +1109,38 @@ f Nothing (Just i) = ImportJust i idefs <- many $ mkIDef <$ reserved "import"- <*> optionMaybe (reserved "qualified")+ <*> optional (reserved "qualified") <*> moduleName- <*> optionMaybe (reserved "hiding" *> importlist)- <*> optionMaybe importlist- <*> optionMaybe (reserved "as" *> moduleName)+ <*> optional (reserved "hiding" *> importlist)+ <*> optional importlist+ <*> optional (reserved "as" *> moduleName) st <- getParserState return Module { extensions = exts- , moduleImports = [("Prelude", ImportAllBut []) | NoImplicitPrelude `notElem` exts] ++ idefs+ , moduleImports = [((mempty, "Prelude"), ImportAllBut []) | NoImplicitPrelude `notElem` exts] ++ idefs , moduleExports = join $ snd <$> header- , definitions = \ge -> first (show +++ id) $ flip runReader (ge, ns) . runWriterT $ runPT' (parseDefs SLabelEnd indentMany' <* eof) st- , sourceCode = str+ , definitions = \ge -> first snd $ runP' (ge, ExpNS) f (parseDefs <* eof) st } -parseLC :: MonadError ErrorMsg m => FilePath -> String -> m Module+parseLC :: FilePath -> String -> Either ParseError Module parseLC f str- = either (throwError . ErrorMsg . show) return- . flip runReader (error "globalenv used", Namespace (Just ExpLevel) True)- . fmap fst . runWriterT- . runParserT'' (parseModule f str) f- . mkStream+ = fst+ . runP (error "globalenv used", ExpNS) f (parseModule f str) $ str +--type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck])+runDefParser :: (MonadFix m, MonadError String m) => DesugarInfo -> DefParser -> m ([Stmt], DesugarInfo)+runDefParser ds_ dp = do++ (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do+ let (x, dns) = dp (ds <> ds_)+ defs <- either (throwError . show) return x+ return (defs, dns, mkDesugarInfo defs)++ mapM_ (maybe (return ()) throwError) dns++ return (sortDefs ds defs, ds)+ -------------------------------------------------------------------------------- pretty print instance Up a => PShow (SExp' a) where@@ -1166,6 +1222,9 @@ shAtom = PS PrecAtom shAtom' = PS PrecAtom'+shTuple xs = prec PrecAtom $ \_ -> case xs of+ [x] -> "((" ++ str x ++ "))"+ xs -> "(" ++ intercalate ", " (map str xs) ++ ")" shAnn _ True x y | str y `elem` ["Type", inGreen "Type"] = x shAnn s simp x y | isAtom x && isAtom y = shAtom' $ str x <> s <> str y shAnn s simp x y = prec PrecAnn $ lpar x <> " " <> const s <> " " <> rpar y
src/LambdaCube/Compiler/Pretty.hs view
@@ -12,8 +12,10 @@ , punctuate , tupled, braces, parens , text+ , nest ) where +import Data.String import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map)@@ -21,11 +23,15 @@ import Control.Monad.Except import Debug.Trace -import Text.PrettyPrint.Compact+import Text.PrettyPrint.Leijen -------------------------------------------------------------------------------- ---instance IsString Doc where fromString = text+instance IsString Doc where fromString = text++instance Monoid Doc where+ mempty = empty+ mappend = (<>) class PShow a where pShowPrec :: Int -> a -> Doc
+ test/PerfReport.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards #-}+import Data.Char+import System.Directory+import System.FilePath+import Text.Printf+import Control.Monad+import Options.Applicative+import Data.Map (Map,(!))+import qualified Data.Map as Map++-- HINT: lambdacube-compiler-test-suite --overall-time performance +RTS -tcurrent.log --machine-readable+-- output: current.log overall-time.txt++data Config+ = Config+ { resultPath :: String+ , output :: Maybe String+ }++sample :: Parser Config+sample = Config+ <$> pure "performance"+ <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name"))++main :: IO ()+main = comparePerf =<< execParser opts+ where+ opts = info (helper <*> sample)+ ( fullDesc+ <> progDesc "compares LambdaCube 3D compiper performance"+ <> header ("LambdaCube 3D compiler performance report"))++comparePerf :: Config -> IO ()+comparePerf cfg@Config{..} = do+ -- read current result+ overallTime <- read <$> readFile "overall-time.txt" :: IO Double+ let toDouble = read :: String -> Double+ toInteger = read :: String -> Integer+ new <- Map.fromList . (:) ("overall_time",show overallTime) . read . unlines . tail . lines <$> readFile "current.log" :: IO (Map String String)+ let totalAlloc a = toInteger $ a ! "bytes allocated"+ peakAlloc a = toInteger $ a ! "peak_megabytes_allocated"+ totalAllocF a = toDouble $ a ! "bytes allocated"+ peakAllocF a = toDouble $ a ! "peak_megabytes_allocated"+ overallTime a = toDouble $ a ! "overall_time"++ putStrLn $ printf "%-20s time: % 6.3fs \tpeak mem: % 6d MBytes total alloc: %d bytes" "CURRENT" (overallTime new) (peakAlloc new) (totalAlloc new)+ -- read previous results+ perfs <- filter ((".perf" ==) . takeExtension) <$> getDirectoryContents "performance" >>= mapM (\n -> (n,) . read <$> readFile (resultPath </> n)) :: IO [(String,Map String String)]+ forM_ perfs $ \(name,old) -> do+ putStrLn $ printf "%-20s time: %+6.3f%% \tpeak mem: %+6.3f%% \ttotal alloc: %+6.3f%%"+ name (100*(overallTime new / overallTime old - 1)) (100*(peakAllocF new / peakAllocF old - 1)) (100*(totalAllocF new / totalAllocF old - 1))+ case output of+ Nothing -> return ()+ Just n -> writeFile (resultPath </> n ++ ".perf") $ show new
test/UnitTests.hs view
@@ -2,7 +2,7 @@ module Main where import Data.Monoid-import Text.Parsec.Pos (SourcePos(..), newPos, sourceName, sourceLine, sourceColumn)+import Text.Megaparsec.Pos (SourcePos(..), newPos, sourceName, sourceLine, sourceColumn) import qualified Data.Map as Map import qualified Data.Set as Set @@ -19,8 +19,8 @@ main = defaultMain $ testGroup "Compiler" [ testGroup "Infer" $ concat [ monoidTestProperties "SI" (arbitrary :: Gen SI)- , monoidTestProperties "Infos" (arbitrary :: Gen Infos)- , monoidTestProperties "MaxDB" (arbitrary :: Gen MaxDB)+-- , monoidTestProperties "Infos" (arbitrary :: Gen Infos) -- list is always a monoid+-- , monoidTestProperties "MaxDB" (arbitrary :: Gen MaxDB) ] ] @@ -29,7 +29,7 @@ -- SourcePos instance Arbitrary SourcePos where- arbitrary = newPos <$> arbitrary <*> arbitrary <*> arbitrary+ arbitrary = newPos <$> arbitrary <*> (getPositive <$> arbitrary) <*> (getPositive <$> arbitrary) shrink pos | n <- sourceName pos, l <- sourceLine pos, c <- sourceColumn pos = [newPos n' l' c' | n' <- shrink n, l' <- shrink l, c' <- shrink c]@@ -59,6 +59,9 @@ testShow (RangeSI a) = "RangeSI " ++ show a -- Infos+{- list is always a monoid+instance Arbitrary Info where+ arbitrary = Info <$> arbitrary instance Arbitrary Infos where arbitrary = Infos . Map.fromList <$> arbitrary@@ -71,11 +74,11 @@ instance TestShow Infos where testShow (Infos i) = "Infos " ++ show i-+-} -- MaxDB-+{- todo instance Arbitrary MaxDB where- arbitrary = MaxDB <$> fmap (fmap abs) arbitrary+ arbitrary = MaxDB <$> {-fmap (fmap abs)-} arbitrary shrink (MaxDB m) = map MaxDB $ shrink m instance MonoidEq MaxDB where@@ -87,7 +90,7 @@ instance TestShow MaxDB where testShow (MaxDB a) = "MaxDB " ++ show a-+-} ----------------------------------------------------------------- Test building blocks class Monoid m => MonoidEq m where
test/runTests.hs view
@@ -1,12 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} module Main where +import Data.Char import Data.List+--import Data.Either import Data.Time.Clock+import Data.Algorithm.Patience import Control.Applicative+import Control.Arrow import Control.Concurrent import Control.Concurrent.Async import Control.Monad@@ -25,6 +30,7 @@ import Text.Printf import LambdaCube.Compiler+import LambdaCube.Compiler.Pretty hiding ((</>)) ------------------------------------------ utils @@ -33,21 +39,22 @@ getDirectoryContentsRecursive path = do l <- map (path </>) . filter (`notElem` [".",".."]) <$> getDirectoryContents path- -- ignore sub directories that name include .ignore (++)- <$> (filter ((".lc" ==) . takeExtension) <$> filterM doesFileExist l)- <*> (fmap concat . mapM getDirectoryContentsRecursive . filter ((".ignore" `notElem`) . takeExtensions') =<< filterM doesDirectoryExist l)+ <$> filterM doesFileExist l+ <*> (fmap mconcat . traverse getDirectoryContentsRecursive =<< filterM doesDirectoryExist l) takeExtensions' :: FilePath -> [String]-takeExtensions' fn = case splitExtension fn of- (_, "") -> []- (fn', ext) -> ext: takeExtensions' fn'+takeExtensions' = snd . splitExtensions' +splitExtensions' fn = case splitExtension fn of+ (a, "") -> (a, [])+ (fn', ext) -> second (ext:) $ splitExtensions' fn'+ getYNChar = do c <- getChar case c of- _ | c `elem` ("yY\n" :: String) -> putChar '\n' >> return True- | c `elem` ("nN\n" :: String) -> putChar '\n' >> return False+ _ | c `elem` ("yY" :: String) -> putChar '\n' >> return True+ | c `elem` ("nN" :: String) -> putChar '\n' >> return False | otherwise -> getYNChar showTime delta@@ -76,10 +83,11 @@ data Config = Config- { cfgVerbose :: Bool- , cfgReject :: Bool- , cfgTimeout :: NominalDiffTime- , cfgIgnore :: [String]+ { cfgVerbose :: Bool+ , cfgReject :: Bool+ , cfgTimeout :: NominalDiffTime+ , cfgIgnore :: [String]+ , cfgOverallTime :: Bool } deriving Show arguments :: Parser (Config, [String])@@ -87,11 +95,12 @@ (,) <$> (Config <$> switch (short 'v' <> long "verbose" <> help "Verbose output during test runs") <*> switch (short 'r' <> long "reject" <> help "Reject test cases with missing, new or different .out files") <*> option (realToFrac <$> (auto :: ReadM Double)) (value 60 <> short 't' <> long "timeout" <> help "Timeout for tests in seconds")- <*> option ((:[]) <$> eitherReader Right) (value [] <> short 'i' <> long "ignore" <> help "Ignore test")+ <*> many (option (eitherReader Right) (short 'i' <> long "ignore" <> help "Ignore test"))+ <*> switch (long "overall-time" <> help "Writes overall time to overall-time.txt") ) <*> many (strArgument idm) -data Res = Passed | Accepted | New | TimedOut | Rejected | Failed | ErrorCatched+data Res = Passed | Accepted | NewRes | TimedOut | Rejected | Failed | ErrorCatched deriving (Eq, Ord, Show) showRes = \case@@ -99,7 +108,7 @@ Failed -> "failed test" Rejected -> "rejected result" TimedOut -> "timed out test"- New -> "new result"+ NewRes -> "new result" Accepted -> "accepted result" Passed -> "passed test" @@ -119,7 +128,7 @@ info (helper <*> arguments) (fullDesc <> header "LambdaCube 3D compiler test suite") - testData <- getDirectoryContentsRecursive testDataPath+ testData <- filter ((".lc" ==) . takeExtension) <$> getDirectoryContentsRecursive testDataPath -- select test set: all test or user selected let (ignoredTests, testSet) = partition (\d -> any (`isInfixOf` d) cfgIgnore) @@ -136,7 +145,7 @@ putStrLn $ "------------------------------------ Running " ++ show (length testSet) ++ " tests" - (Right resultDiffs, _)+ resultDiffs <- runMM (ioFetch [".", testDataPath]) $ forM (zip [1..] testSet) $ doTest cfg @@ -155,22 +164,29 @@ putStrLn $ unlines $ reverse $ concat [ sh (\s ty -> ty == x && p s) (w ++ showRes x) | (w, p) <- [("", not . isWip), ("wip ", isWip)]- , x <- [ErrorCatched, Failed, Rejected, TimedOut, New, Accepted]+ , x <- [ErrorCatched, Failed, Rejected, TimedOut, NewRes, Accepted] ] ++ sh (\s ty -> ty == Passed && isWip s) "wip passed test" - putStrLn $ "Overall time: " ++ showTime (sum $ map fst resultDiffs)+ let overallTime = sum $ map fst resultDiffs+ putStrLn $ "Overall time: " ++ showTime overallTime+ when cfgOverallTime $ writeFile "overall-time.txt" $ show (realToFrac overallTime :: Double) when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, not $ isWip f]) exitFailure putStrLn "All OK" when (or [erroneous r | ((_, r), f) <- zip resultDiffs testSet, isWip f]) $ putStrLn "Only work in progress test cases are failing." +splitMPath fn = (joinPath $ reverse as, foldr1 (</>) $ reverse bs ++ [y], intercalate "." $ reverse bs ++ [y])+ where+ (bs, as) = span (\x -> not (null x) && isUpper (head x)) $ reverse xs+ (xs, y) = map takeDirectory . splitPath *** id $ splitFileName $ dropExtension fn+ doTest Config{..} (i, fn) = do- liftIO $ putStr $ fn ++ " "+ liftIO $ putStr $ pa ++ " " ++ mn ++ " " ++ concat exts ++ " " (runtime, res) <- mapMMT (timeOut cfgTimeout $ Left ("!Timed Out", TimedOut)) $ catchErr (\e -> return $ Left (tab "!Crashed" e, ErrorCatched))- $ liftIO . evaluate =<< (force <$> action)+ $ liftIO . evaluate =<< (force . f <$> getMain) liftIO $ putStr $ "(" ++ showTime runtime ++ ")" ++ " " (msg, result) <- case res of Left x -> return x@@ -178,25 +194,26 @@ liftIO $ putStrLn msg return (runtime, result) where- n = dropExtension fn+ (splitMPath -> (pa, mn', mn), reverse -> exts) = splitExtensions' $ dropExtension fn - action = f <$> (Right <$> getDef n "main" Nothing) `catchMM` (return . Left . show)+ getMain = do+ (is, res) <- local (const $ ioFetch [pa]) $ getDef (mn' ++ concat exts ++ ".lc") "main" Nothing+ (,) is <$> case res of+ Left err -> return $ Left err+ Right (fname, x@Left{}) -> return $ Right (fname, x)+ Right (fname, x@Right{}) -> Right (fname, x) <$ removeFromCache fname - f | not $ isReject fn = \case- Left e -> Left (tab "!Failed" e, Failed)- Right (fname, Left e, i)- -> Right ("typechecked module"- , unlines $ e: "tooltips:": [ ppShow r ++ " " ++ intercalate " | " m- | (r, m) <- listInfos i])- Right (fname, Right (e, te), i)- | True <- i `deepseq` False -> error "impossible"- | te == outputType -> Right ("compiled pipeline", show $ compilePipeline OpenGL33 (e, te))- | e == trueExp -> Right ("reducted main", ppShow e)- | te == boolType -> Left (tab "!Failed" $ "main should be True but it is \n" ++ ppShow e, Failed)- | otherwise -> Right ("reduced main " ++ ppShow te, ppShow e)- | otherwise = \case- Left e -> Right ("error message", e)- Right _ -> Left (tab "!Failed" "failed to catch error", Failed)+ f (i, e) | not $ isReject fn = case e of+ Left e -> Left (unlines $ tab "!Failed" e: listTraceInfos i, Failed)+ Right (fname, Left e) -> Right ("typechecked module" , unlines $ e: listAllInfos i)+ Right (fname, Right (e, te))+ | te == outputType -> Right ("compiled pipeline", prettyShowUnlines $ compilePipeline OpenGL33 (e, te))+ | e == trueExp -> Right ("reducted main", ppShow $ unfixlabel e)+ | te == boolType -> Left (tab "!Failed" $ "main should be True but it is \n" ++ ppShow e, Failed)+ | otherwise -> Right ("reduced main " ++ ppShow te, ppShow e)+ | otherwise = case e of+ Left e -> Right ("error message", unlines $ e: listAllInfos i)+ Right _ -> Left (tab "!Failed" "failed to catch error", Failed) tab msg | isWip fn && cfgReject = const msg@@ -205,44 +222,35 @@ compareResult msg ef e = doesFileExist ef >>= \b -> case b of False | cfgReject -> return ("!Missing .out file", Rejected)- | otherwise -> writeFile ef e >> return ("New .out file", New)+ | otherwise -> writeFile ef e >> return ("New .out file", NewRes) True -> do- e' <- readFileStrict ef- case map fst $ filter snd $ zip [0..] $ zipWith (/=) e e' ++ replicate (abs $ length e - length e') True of- [] -> return ("OK", Passed)+ e' <- lines <$> readFileStrict ef+ let d = diff e' $ lines e+ case d of+ _ | all (\case Both{} -> True; _ -> False) d -> return ("OK", Passed) rs | cfgReject-> return ("!Different .out file", Rejected) | otherwise -> do- printOldNew msg (showRanges ef rs e') (showRanges ef rs e)+ mapM_ putStrLn $ printOldNew msg d putStrLn $ ef ++ " has changed." putStr $ "Accept new " ++ msg ++ " (y/n)? "- c <- length e' `seq` getYNChar+ c <- getYNChar if c then writeFile ef e >> return ("Accepted .out file", Accepted) else return ("!Rejected .out file", Rejected) -printOldNew msg old new = do- putStrLn $ msg ++ " has changed."- putStrLn "------------------------------------------- Old"- putStrLn old- putStrLn "------------------------------------------- New"- putStrLn new- putStrLn "-------------------------------------------"+printOldNew :: String -> [Item String] -> [String]+printOldNew msg d = (msg ++ " has changed.") : ff [] 0 d+ where+ ff acc n (x@(Both a b): ds) = [a' | n < 5] ++ ff (a':acc) (n+1) ds where a' = " " ++ a+ ff acc n (Old a: ds) = g acc n ++ (ESC "42" ("< " ++ ESC "49" a)): ff [] 0 ds+ ff acc n (New b: ds) = g acc n ++ (ESC "41" ("> " ++ ESC "49" b)): ff [] 0 ds+ ff _ _ [] = []+ g acc n | n < 5 = []+ g acc n | n > 10 = "___________": reverse (take 5 acc)+ g acc n = reverse (take (n-5) acc) pad n s = s ++ replicate (n - length s) ' ' limit :: String -> Int -> String -> String limit msg n s = take n s ++ if null (drop n s) then "" else msg--showRanges :: String -> [Int] -> String -> String-showRanges fname is e = (if head rs == 0 then "" else "...\n")- ++ limit ("\n... (see " ++ fname ++ " for more differences)") 140000 (intercalate "\n...\n" $ f (zipWith (-) rs (0:rs)) e)- where- f :: [Int] -> String -> [String]- f (i:is) e = g is $ drop i e- f [] "" = []- f [] _ = ["\n..."]- g (i:is) e = take i e: f is (drop i e)- rs = (head is - x) : concat [[a + x, b - x] | (a, b) <- zip is (tail is), a + y < b] ++ [last is + x]- x = 100000- y = 3*x
tool/Compiler.hs view
@@ -3,6 +3,8 @@ import Data.Aeson import qualified Data.ByteString.Lazy as B import System.FilePath+import Data.Version+import Paths_lambdacube_compiler (version) import LambdaCube.Compiler @@ -11,6 +13,8 @@ { srcName :: String , backend :: Backend , includePaths :: [FilePath]+ , pretty :: Bool+ , output :: Maybe String } sample :: Parser Config@@ -18,6 +22,8 @@ <$> argument str (metavar "SOURCE_FILE") <*> flag OpenGL33 WebGL1 (long "webgl" <> help "generate WebGL 1.0 pipeline" ) <*> pure ["."]+ <*> switch (long "pretty" <> help "pretty prints pipeline")+ <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name")) main :: IO () main = compile =<< execParser opts@@ -25,14 +31,30 @@ opts = info (helper <*> sample) ( fullDesc <> progDesc "compiles LambdaCube graphics pipeline source to JSON IR"- <> header "LambdaCube 3D compiler" )+ <> header ("LambdaCube 3D compiler " ++ showVersion version)) compile :: Config -> IO ()-compile Config{..} = do- let dropExt n | takeExtension n == ".lc" = dropExtension n- dropExt n = n- baseName = dropExt srcName- pplRes <- compileMain includePaths backend baseName- case pplRes of+compile cfg@Config{..} = do+ let ext = takeExtension srcName+ baseName | ext == ".lc" = dropExtension srcName+ | otherwise = srcName+ withOutName n = maybe n id output+ case ext of+ ".json" | pretty -> prettyPrint cfg+ _ -> do+ pplRes <- compileMain includePaths backend srcName+ case pplRes of+ Left err -> fail err+ Right ppl -> case pretty of+ False -> B.writeFile (withOutName $ baseName <> ".json") $ encode ppl+ True -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl++prettyPrint :: Config -> IO ()+prettyPrint Config{..} = do+ let baseName = dropExtension srcName+ withOutName n = maybe n id output+ json <- B.readFile srcName+ case eitherDecode json :: Either String Pipeline of Left err -> putStrLn err- Right ppl -> B.writeFile (baseName <> ".json") $ encode ppl+ Right ppl -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl+