diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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) + + diff --git a/backendtest/EditorExamplesTest.hs b/backendtest/EditorExamplesTest.hs new file mode 100644 --- /dev/null +++ b/backendtest/EditorExamplesTest.hs @@ -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 diff --git a/backendtest/TestData.hs b/backendtest/TestData.hs new file mode 100644 --- /dev/null +++ b/backendtest/TestData.hs @@ -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 + diff --git a/backendtest/TestServer.hs b/backendtest/TestServer.hs new file mode 100644 --- /dev/null +++ b/backendtest/TestServer.hs @@ -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 +-} diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal --- a/lambdacube-compiler.cabal +++ b/lambdacube-compiler.cabal @@ -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 diff --git a/lc/Builtins.lc b/lc/Builtins.lc --- a/lc/Builtins.lc +++ b/lc/Builtins.lc @@ -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` diff --git a/lc/Internals.lc b/lc/Internals.lc --- a/lc/Internals.lc +++ b/lc/Internals.lc @@ -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 +-} diff --git a/lc/Prelude.lc b/lc/Prelude.lc --- a/lc/Prelude.lc +++ b/lc/Prelude.lc @@ -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 diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs --- a/src/LambdaCube/Compiler.hs +++ b/src/LambdaCube/Compiler.hs @@ -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' ++ ["<>"]{-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 diff --git a/src/LambdaCube/Compiler/CoreToIR.hs b/src/LambdaCube/Compiler/CoreToIR.hs --- a/src/LambdaCube/Compiler/CoreToIR.hs +++ b/src/LambdaCube/Compiler/CoreToIR.hs @@ -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 diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs @@ -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 -- <> 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 -- __ - 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 "<>" - -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 -- <> 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 -- __ + 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 "<>" + +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) diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs --- a/src/LambdaCube/Compiler/Lexer.hs +++ b/src/LambdaCube/Compiler/Lexer.hs @@ -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" diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs --- a/src/LambdaCube/Compiler/Parser.hs +++ b/src/LambdaCube/Compiler/Parser.hs @@ -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 diff --git a/src/LambdaCube/Compiler/Pretty.hs b/src/LambdaCube/Compiler/Pretty.hs --- a/src/LambdaCube/Compiler/Pretty.hs +++ b/src/LambdaCube/Compiler/Pretty.hs @@ -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 diff --git a/test/PerfReport.hs b/test/PerfReport.hs new file mode 100644 --- /dev/null +++ b/test/PerfReport.hs @@ -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 diff --git a/test/UnitTests.hs b/test/UnitTests.hs --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -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 diff --git a/test/runTests.hs b/test/runTests.hs --- a/test/runTests.hs +++ b/test/runTests.hs @@ -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 diff --git a/tool/Compiler.hs b/tool/Compiler.hs --- a/tool/Compiler.hs +++ b/tool/Compiler.hs @@ -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 +