diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,49 @@ +# v0.6 + +- new features + - support mutual constant and function definitions + - support pattern type annotations + - support guards + where + - support view patterns + - support pattern guards + - support as-patterns + - implement pattern match reachability and exhaustiveness warnings + - support parsing only + - support printing desugared source code +- improvements + - allow pattern match on tuple types + - implement constraint kinds (useful for type classes) + - improve pretty printing + - better presentation of types in editor tooltips + - better error messages (e.g. for mismatching operator fixities) + - speedup the builtin interpreter in the compiler +- bugfixes + - fix local function handling + - fix parens around operators + - fix parsing of operator definitions + - fix parsing of sections + - fix parsing of literals + - fix switching to type namespace after @ + - fix a bug in escape code parsing +- documentation + - reorganise and cleanup the compiler sources + - begin to write developer's guide + - documentation on pattern match compilation +- dependencies + - use megaparsec 5.0 + - switch to ansi-wl-pprint + - allow newer base, optparse-applicative and QuickCheck libraries +- other + - move the TODOs to Trello: https://trello.com/b/TcuVPBAR/lambdacube3d + - work on prototypes + - Reducer.hs -- experiment with lazy evaluation in the ST monad + - ShiftReducer.hs -- experiment with lazy evaluation purely, with incremental GC + - LamMachine.hs -- experiment with lazy evaluation purely, with incremental GC (next version) + - Inspector.hs -- a tool for inspect the state of LamMachine, intended for debugging/visualizing lazy evaluation + - LamMachineV2.hs -- experiment with lazy evaluation in the ST monad, with explicit, generational GC + + # v0.5 - compiler diff --git a/backendtest/EditorExamplesTest.hs b/backendtest/EditorExamplesTest.hs --- a/backendtest/EditorExamplesTest.hs +++ b/backendtest/EditorExamplesTest.hs @@ -80,7 +80,7 @@ ppls <- forM tests $ \name -> do putStrLn $ "compile: " ++ name LambdaCube.compileMain [path] OpenGL33 name >>= \case - Left err -> fail $ "compile error:\n" ++ err + Left err -> fail $ "compile error:\n" ++ show err Right ppl -> return $ PipelineInfo { pipelineName = path name , pipeline = ppl 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.5.0.1 +version: 0.6.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 @@ -21,14 +21,31 @@ lc/Internals.lc lc/Prelude.lc -Flag onlytestsuite - Description: Only compiles the library and testsuit - Default: False +-- flags explanation (Y-Yes,N-No,X-no effect) +-- executables/flags: | default, cli, testsuite, coverage, alltest, profiling +-- lc Y Y X X X X +-- lambdacube-compiler-unit-tests N X X X Y X +-- lambdacube-compiler-test-suite N X Y X Y X +-- lambdacube-compiler-performance-report N X X X Y X +-- lambdacube-backend-test-server N X X X Y X +-- lambdacube-compiler-coverage-test-suite N X X Y X X +Flag cli + Description: Compiles 'lc' command line tool + Default: True + Flag profiling Description: Enable profiling Default: False +Flag alltest + Description: Additionally compiles the testsuite, unit tests, backend test server, performance report (useful for development) + Default: False + +Flag testsuite + Description: Compiles the library and testsuite + Default: False + Flag coverage Description: Enable coverage reporting Default: False @@ -38,16 +55,22 @@ location: https://github.com/lambdacube3d/lambdacube-compiler library - other-modules: - Paths_lambdacube_compiler exposed-modules: - -- Compiler - LambdaCube.Compiler + LambdaCube.Compiler.Utils + LambdaCube.Compiler.DeBruijn LambdaCube.Compiler.Pretty + LambdaCube.Compiler.DesugaredSource + LambdaCube.Compiler.Patterns + LambdaCube.Compiler.Statements LambdaCube.Compiler.Lexer LambdaCube.Compiler.Parser + LambdaCube.Compiler.Core + LambdaCube.Compiler.InferMonad LambdaCube.Compiler.Infer LambdaCube.Compiler.CoreToIR + LambdaCube.Compiler + other-modules: + Paths_lambdacube_compiler other-extensions: LambdaCase PatternSynonyms @@ -70,16 +93,16 @@ -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - aeson >= 0.9 && <1, - base >=4.7 && <4.9, + aeson >=0.9 && <0.12, + base >=4.7 && <4.10, + semigroups, containers >=0.5 && <0.6, - deepseq, - directory, + directory >=1.2 && <1.3, exceptions >= 0.8 && <0.9, - filepath, + filepath >=1.4 && <1.5, mtl >=2.2 && <2.3, - megaparsec >= 4.3.0 && <4.5, - wl-pprint >=1.2 && <1.3, + megaparsec >=5.0 && <5.1, + ansi-wl-pprint >=0.6 && <0.7, pretty-show >= 1.6.9, text >= 1.2 && <1.3, lambdacube-ir == 0.3.*, @@ -89,93 +112,107 @@ default-language: Haskell2010 if flag(profiling) - GHC-Options: -fprof-auto -rtsopts + GHC-Options: -fprof-auto +executable lc + hs-source-dirs: tool + main-is: Compiler.hs + default-language: Haskell2010 + if flag(cli) + Buildable: True + else + Buildable: False + + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository + build-depends: + base < 4.10, + lambdacube-compiler, + optparse-applicative >=0.12 && <0.14, + aeson >=0.9 && <0.12, + bytestring == 0.10.*, + filepath >=1.4 && <1.5 + +------------------------ +-- tests for development +------------------------ + executable lambdacube-compiler-unit-tests hs-source-dirs: test main-is: UnitTests.hs default-language: Haskell2010 + if flag(alltest) + Buildable: True + else + Buildable: False + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - base < 4.9, + base < 4.10, + semigroups, containers >=0.5 && <0.6, lambdacube-compiler, - megaparsec >= 4.3.0 && <4.5, - QuickCheck >= 2.8.2 && <2.9, + megaparsec >=5.0 && <5.1, + QuickCheck >= 2.8.2 && <2.10, tasty >= 0.11 && <0.12, tasty-quickcheck >=0.8 && <0.9 - if flag(onlytestsuite) - Buildable: False - else - Buildable: True - executable lambdacube-compiler-test-suite hs-source-dirs: test main-is: runTests.hs default-language: Haskell2010 + if flag(alltest) || flag(testsuite) + Buildable: True + else + Buildable: False + + if flag(profiling) + GHC-Options: -fprof-auto -rtsopts + else + GHC-Options: -rtsopts + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - aeson >= 0.9 && <1, + aeson >=0.9 && <0.12, async >= 2.0 && <2.2, - base < 4.9, + base < 4.10, + semigroups, containers >=0.5 && <0.6, - deepseq, - directory, + deepseq >=1.4 && <1.5, + directory >=1.2 && <1.3, exceptions >= 0.8 && <0.9, - filepath, + filepath >=1.4 && <1.5, lambdacube-compiler, mtl >=2.2 && <2.3, monad-control >= 1.0 && <1.1, - optparse-applicative == 0.12.*, - megaparsec >= 4.3.0 && <4.5, - wl-pprint >=1.2 && <1.3, + optparse-applicative >=0.12 && <0.14, + megaparsec >=5.0 && <5.1, + ansi-wl-pprint >=0.6 && <0.7, patience >= 0.1 && < 0.2, text >= 1.2 && <1.3, - time >= 1.5 && <1.6, + time >= 1.5 && <1.7, 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 - default-language: Haskell2010 + if flag(alltest) + Buildable: True + else + Buildable: False -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - base < 4.9, - lambdacube-compiler, - optparse-applicative == 0.12.*, - aeson >= 0.9 && <1, - bytestring == 0.10.*, - filepath == 1.4.* - - if flag(onlytestsuite) - Buildable: False - else - Buildable: True + base < 4.10, + directory >=1.2 && <1.3, + filepath >=1.4 && <1.5, + containers >=0.5 && <0.6, + optparse-applicative >=0.12 && <0.14 executable lambdacube-backend-test-server hs-source-dirs: backendtest @@ -184,19 +221,25 @@ other-modules: EditorExamplesTest TestData + if flag(alltest) + Buildable: True + else + Buildable: False + -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - base < 4.9, + base < 4.10, + semigroups, 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, + optparse-applicative >=0.12 && <0.14, + aeson >=0.9 && <0.12, bytestring == 0.10.*, - filepath == 1.4.*, - directory, + filepath >=1.4 && <1.5, + directory >=1.2 && <1.3, websockets >= 0.9.6.1, JuicyPixels >=3.2.7 && <3.3, vect >= 0.4.7, @@ -204,12 +247,6 @@ 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 @@ -227,23 +264,23 @@ -- CAUTION: When the build-depends change, please bump the git submodule in lambdacube-docker repository build-depends: - aeson >= 0.9 && <1, + aeson >=0.9 && <0.12, async >= 2.0 && <2.2, - base < 4.9, + base < 4.10, + semigroups, containers >=0.5 && <0.6, - deepseq, - directory, + deepseq >=1.4 && <1.5, + directory >=1.2 && <1.3, exceptions >= 0.8 && <0.9, - filepath, + filepath >=1.4 && <1.5, lambdacube-ir == 0.3.*, mtl >=2.2 && <2.3, monad-control >= 1.0 && <1.1, - optparse-applicative == 0.12.*, - megaparsec >= 4.3.0 && <4.5, - wl-pprint >=1.2 && <1.3, + optparse-applicative >=0.12 && <0.14, + megaparsec >=5.0 && <5.1, + ansi-wl-pprint >=0.6 && <0.7, pretty-show >= 1.6.9, patience >= 0.1 && < 0.2, text >= 1.2 && <1.3, - time >= 1.5 && <1.6, + time >= 1.5 && <1.7, vector >= 0.11 && <0.12 - diff --git a/lc/Builtins.lc b/lc/Builtins.lc --- a/lc/Builtins.lc +++ b/lc/Builtins.lc @@ -479,7 +479,7 @@ rasterizePrimitive :: ( map Interpolated b ~ interpolation - , a ~ 'Cons (Vec 4 Float) b ) + , a ~ Vec 4 Float: b ) => HList interpolation -- tuple of Smooth & Flat -> RasterContext (HList a) x -> Primitive (HList a) x @@ -489,9 +489,9 @@ type family ImageLC a :: Nat where ImageLC (Image n t) = n -allSame :: [a] -> Type -allSame [] = 'Unit -allSame [x] = 'Unit +allSame :: [a] -> Constraint +allSame [] = 'CUnit +allSame [x] = 'CUnit allSame (x: y: xs) = 'T2 (x ~ y) (allSame (y:xs)) sameLayerCounts a = allSame (map 'ImageLC a) diff --git a/lc/Internals.lc b/lc/Internals.lc --- a/lc/Internals.lc +++ b/lc/Internals.lc @@ -18,8 +18,17 @@ unsafeCoerce :: forall a b . a -> b +data Constraint where + CUnit :: Constraint + CEmpty :: String -> Constraint + +type family CW (c :: Constraint) -- where +{- + CW 'CUnit = Unit + CW ('CEmpty s) = Empty s +-} -- equality constraints -type family EqCT (t :: Type) (a :: t) (b :: t) +type family EqCT (t :: Type) (a :: t) (b :: t) :: Constraint {- coe :: forall (a :: Type) (b :: Type) -> EqCT Type a b -> a -> b coe a b TT x = unsafeCoerce @a @b x @@ -31,7 +40,12 @@ parEval :: forall a -> a -> a -> a -- conjuction of constraints -type family T2 a b +type family T2 (x :: Constraint) (y :: Constraint) :: Constraint +{- +type instance T2 'CUnit c = c +type instance T2 c 'CUnit = c +type instance T2 ('CEmpty s) ('CEmpty s') = 'CEmpty (s {- ++ s' TODO-}) +-} match'Type :: forall (m :: Type -> Type) -> m Type -> forall (t :: Type) -> m t -> m t @@ -119,7 +133,7 @@ Succ a == Succ b = a == b _ == _ = False -data List a = Nil | Cons a (List a) +data List a = Nil | (:) a (List a) infixr 5 : @@ -132,22 +146,8 @@ :: forall (e :: Type) (f :: List Type) . forall c -> (e -> HList f -> c) - -> HList (Cons e f) + -> HList (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 @@ -126,16 +126,16 @@ data RecordC (xs :: [RecItem]) = RecordCons (HList (map recItemType xs)) -isKeyC _ _ [] = 'Empty "" +isKeyC _ _ [] = 'CEmpty "" 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 +fstTup = hlistConsCase _ (\a _ -> a) +sndTup = hlistConsCase _ (\_ a -> a) -- todo: don't use unsafeCoerce 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))) +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 @(CW (isKeyC s a xs))) (RecordCons (sndTup (unsafeCoerce @_ @(HList '(a : map recItemType xs)) ts))) --------------------------------------- HTML colors @@ -387,5 +387,4 @@ (!!) :: [a] -> Int -> a (x : _) !! 0 = x (_ : xs) !! n = xs !! (n-1) - diff --git a/src/LambdaCube/Compiler.hs b/src/LambdaCube/Compiler.hs --- a/src/LambdaCube/Compiler.hs +++ b/src/LambdaCube/Compiler.hs @@ -14,13 +14,13 @@ , MMT, runMMT, mapMMT , MM, runMM - , catchErr , ioFetch, decideFilePath - , getDef, compileMain, preCompile + , loadModule, getDef, compileMain, parseModule, preCompile , removeFromCache , compilePipeline , ppShow + , plainShow , prettyShowUnlines ) where @@ -29,66 +29,35 @@ import Data.Function import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import qualified Data.IntMap.Strict as IM import Control.Monad.State.Strict import Control.Monad.Reader import Control.Monad.Writer import Control.Monad.Except -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 qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Text.Show.Pretty as PP +--import Debug.Trace import LambdaCube.IR as IR import LambdaCube.Compiler.Pretty hiding (()) -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.DesugaredSource (Module_(..), Export(..), ImportItems (..), Stmt) +import LambdaCube.Compiler.Parser (runDefParser, parseLC, DesugarInfo, Module) +import LambdaCube.Compiler.InferMonad (GlobalEnv, initEnv) +import LambdaCube.Compiler.Infer (inference) import LambdaCube.Compiler.CoreToIR +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DesugaredSource as Exported (FileInfo(..), Range(..), SPos(..), pattern SPos, SIName(..), pattern SIName, sName, SI(..)) +import LambdaCube.Compiler.Core as Exported (mkDoc, Exp, ExpType(..), pattern ET, outputType, boolType, trueExp, hnf) +import LambdaCube.Compiler.InferMonad as Exported (errorRange, listAllInfos, listAllInfos', listTypeInfos, listErrors, listWarnings, listTraceInfos, Infos, Info(..)) +--import LambdaCube.Compiler.Infer as Exported () + -- inlcude path for: Builtins, Internals and Prelude import Paths_lambdacube_compiler (getDataDir) -------------------------------------------------------------------------------- -readFileStrict :: FilePath -> IO String -readFileStrict = fmap T.unpack . TIO.readFile - -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" - -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 - - isMultilineString ('\\':'n':xs) = True - isMultilineString ('\\':c:xs) = isMultilineString xs - isMultilineString ('"':xs) = False - isMultilineString (x:xs) = isMultilineString xs - isMultilineString [] = False - --------------------------------------------------------------------------------- - type MName = String type SName = String type SourceCode = String @@ -115,20 +84,20 @@ 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)) +type ModuleFetcher m = Maybe FilePath -> Either FilePath MName -> m (Either Doc (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-})) + let paths = map (id &&& id) paths' ++ [(preludePath, "<>")] + find ((x, (x', mn)): xs) = liftIO (readFileIfExists x) >>= maybe (find xs) (\src -> return $ Right (x', mn, liftIO src)) + find [] = return $ Left $ "can't find" <+> either (("lc file" <+>) . text) (("module" <+>) . text) n + <+> "in path" <+> hsep (text . snd <$> paths) 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) + lcModuleFile (path, path') = case n of + Left n -> (path n, (path' n, fileNameToModuleName n)) + Right n -> (path moduleNameToFileName n, (path' moduleNameToFileName n, n)) -------------------------------------------------------------------------------- @@ -141,81 +110,83 @@ runMM :: Monad m => ModuleFetcher (MMT m x) -> MMT m x a -> m a runMM fetcher - = flip evalStateT mempty + = flip evalStateT (Modules mempty mempty 1) . flip runReaderT fetcher . runMMT -catchErr :: (MonadCatch m, NFData a, MonadIO m) => (String -> m a) -> m a -> m a -catchErr er m = (force <$> m >>= liftIO . evaluate) `catch` getErr `catch` getPMatchFail - where - getErr (e :: ErrorCall) = catchErr er $ er $ show e - getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e - -- TODO: remove dependent modules from cache too? removeFromCache :: Monad m => FilePath -> MMT m x () -removeFromCache f = modify $ Map.delete f - -type Module' x = (SourceCode, Either String{-error msg-} (Module, x, Either String{-error msg-} (DesugarInfo, GlobalEnv))) +removeFromCache f = modify $ \m@(Modules nm im ni) -> case Map.lookup f nm of + Nothing -> m + Just i -> Modules (Map.delete f nm) (IM.delete i im) ni -type Modules x = Map FilePath (Module' x) +type Module' x = (SourceCode, Either Doc{-error msg-} (Module, x, Either Doc{-error msg-} (DesugarInfo, GlobalEnv))) -(<&>) = flip (<$>) +data Modules x = Modules + { moduleIds :: !(Map FilePath Int) + , modules :: !(IM.IntMap (FileInfo, Module' x)) + , nextMId :: !Int + } -loadModule :: MonadMask m => (Infos -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either String (FilePath, Module' x)) +loadModule :: MonadMask m => ((Infos, [Stmt]) -> x) -> Maybe FilePath -> Either FilePath MName -> MMT m x (Either Doc (FileInfo, 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 + c <- gets $ Map.lookup fname . moduleIds case c of - Just x -> return $ Right (fname, x) - Nothing -> do + Just fid -> gets $ Right . (IM.! fid) . modules + _ -> do src <- srcm - res <- case parseLC fname src of - Left e -> return $ Left $ show e + fid <- gets nextMId + modify $ \(Modules nm im ni) -> Modules (Map.insert fname fid nm) im $ ni+1 + let fi = FileInfo fid fname mname src + res <- case parseLC fi of + Left e -> return $ Left $ text $ 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" + modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fi, (src, Right (e, ex mempty, Left $ "cycles in module imports:" <+> pShow mname <+> pShow (fst <$> moduleImports e)))) im) ni + ms <- forM (moduleImports e) $ \(m, is) -> loadModule ex (Just fname) (Right $ sName m) <&> \r -> case r of + Left err -> Left $ pShow m <+> "is not found" Right (fb, (src, dsge)) -> - either (Left . const (snd m ++ " couldn't be parsed")) + either (Left . const (pShow m <+> "couldn't be parsed")) (\(pm, x, e) -> either - (Left . const (snd m ++ " couldn't be typechecked")) + (Left . const (pShow m <+> "couldn't be typechecked")) (\(ds, ge) -> Right (ds{-todo: filter-}, Map.filterWithKey (\k _ -> filterImports is k) ge)) e) dsge let (res, err) = case sequence ms of - Left err -> (ex mempty, Left err) + Left err -> (ex mempty, Left $ pShow 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) + Left err -> (ex mempty, Left $ pShow err) + Right (defs, warnings, dsinfo) -> (,) (ex (map ParseWarning warnings ++ is, defs)) $ case res of + Left err -> Left $ pShow err Right (mconcat -> newge) -> - right mconcat $ forM (fromMaybe [ExportModule (mempty, mname)] $ moduleExports e) $ \case - ExportId (snd -> d) -> case Map.lookup d newge of + right mconcat $ forM (fromMaybe [ExportModule $ SIName mempty mname] $ moduleExports e) $ \case + ExportId (sName -> 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) + Nothing -> Left $ text d <+> "is not defined" + ExportModule (sName -> 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) + [] -> Left $ "empty export list in module" <+> text 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)) + modify $ \(Modules nm im ni) -> Modules nm (IM.insert fid (fi, (src, res)) im) ni + return $ Right (fi, (src, res)) where - filterImports (ImportAllBut ns) = not . (`elem` map snd ns) - filterImports (ImportJust ns) = (`elem` map snd ns) + filterImports (ImportAllBut ns) = not . (`elem` map sName ns) + filterImports (ImportJust ns) = (`elem` map sName ns) -- used in runTests -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 +getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m (Infos, [Stmt]) ((Infos, [Stmt]), Either Doc (FileInfo, Either Doc ExpType)) +getDef = getDef_ id + +getDef_ ex m d ty = loadModule ex 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 @@ -224,33 +195,44 @@ , 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" + -> Left $ "type of" <+> text d <+> "should be" <+> pShow ty <+> "instead of" <+> pShow thy + | otherwise -> Right (ET e thy) + Nothing -> Left $ text d <+> "is not found" ) -compilePipeline' backend m - = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef m "main" (Just outputType) +compilePipeline' ex backend m + = second (either Left (fmap (compilePipeline backend) . snd)) <$> getDef_ ex m "main" (Just outputType) -- | most commonly used interface for end users -compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either String IR.Pipeline) +compileMain :: [FilePath] -> IR.Backend -> MName -> IO (Either Doc IR.Pipeline) compileMain path backend fname - = fmap snd $ runMM (ioFetch path) $ compilePipeline' backend fname + = fmap snd $ runMM (ioFetch path) $ compilePipeline' (const ()) backend fname +parseModule :: [FilePath] -> MName -> IO (Either Doc String) +parseModule path fname = runMM (ioFetch path) $ loadModule snd Nothing (Left fname) <&> \case + Left err -> Left err + Right (fname, (src, Left err)) -> Left err + Right (fname, (src, Right (pm, infos, _))) -> Right $ pPrintStmts infos + -- used by the compiler-service of the online editor -preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either String IR.Pipeline, Infos)) +preCompile :: (MonadMask m, MonadIO m) => [FilePath] -> [FilePath] -> Backend -> FilePath -> IO (String -> m (Either Doc IR.Pipeline, (Infos, String))) preCompile paths paths' backend mod = do - res <- runMM (ioFetch paths) $ loadModule id Nothing $ Left mod + res <- runMM (ioFetch paths) $ loadModule ex Nothing $ Left mod case res of - Left err -> error $ "Prelude could not compiled: " ++ err - Right (src, prelude) -> return compile + Left err -> error $ "Prelude could not compiled:" ++ show err + Right (fi, prelude) -> return compile where - compile src = fmap (first (left removeEscs)) . runMM fetch $ do - modify $ Map.insert ("." "Prelude.lc") prelude - (snd &&& fst) <$> compilePipeline' backend "Main" + compile src = runMM fetch $ do + let pname = "." "Prelude.lc" + modify $ \(Modules nm im ni) -> Modules (Map.insert pname ni nm) (IM.insert ni (FileInfo ni pname "Prelude" $ fileContent fi, prelude) im) (ni+1) + (snd &&& fst) <$> compilePipeline' ex backend "Main" where fetch imp = \case Left "Prelude" -> return $ Right ("./Prelude.lc", "Prelude", undefined) Left "Main" -> return $ Right ("./Main.lc", "Main", return src) n -> ioFetch paths' imp n + where + ex = second pPrintStmts + +pPrintStmts = unlines . map ((++"\n") . plainShow) diff --git a/src/LambdaCube/Compiler/Core.hs b/src/LambdaCube/Compiler/Core.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/Core.hs @@ -0,0 +1,683 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +--{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- TODO: remove +--{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove +module LambdaCube.Compiler.Core where + +import Data.Monoid +import Data.Function +import Data.List +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (braces, parens) +import LambdaCube.Compiler.DesugaredSource + +-------------------------------------------------------------------------------- names with infos + +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 Int{-num of global vars-} FunDef Type + +data CaseFunName = CaseFunName FName Type Int{-num of parameters-} + +data TyCaseFunName = TyCaseFunName FName Type + +data FunDef + = DeltaDef !Int{-arity-} (FreeVars -> [Exp]{-args in reversed order-} -> Exp) + | NoDef + | ExpDef Exp + +class HasFName a where getFName :: a -> FName + +instance HasFName ConName where getFName (ConName n _ _) = n +instance HasFName TyConName where getFName (TyConName n _ _ _ _) = n +instance HasFName FunName where getFName (FunName n _ _ _) = n +instance HasFName CaseFunName where getFName (CaseFunName n _ _) = n +instance HasFName TyCaseFunName where getFName (TyCaseFunName n _) = n + +instance Eq ConName where (==) = (==) `on` getFName +instance Eq TyConName where (==) = (==) `on` getFName +instance Eq FunName where (==) = (==) `on` getFName +instance Eq CaseFunName where (==) = (==) `on` getFName +instance Eq TyCaseFunName where (==) = (==) `on` getFName + +instance Show ConName where show (ConName n _ _) = show n +instance PShow ConName where pShow (ConName n _ _) = pShow n +instance Show TyConName where show (TyConName n _ _ _ _) = show n +instance PShow TyConName where pShow (TyConName n _ _ _ _) = pShow n +instance Show FunName where show (FunName n _ _ _) = show n +instance PShow FunName where pShow (FunName n _ _ _) = pShow n +instance Show CaseFunName where show (CaseFunName n _ _) = CaseName $ show n +instance PShow CaseFunName where pShow (CaseFunName n _ _) = text $ CaseName $ show n +instance Show TyCaseFunName where show (TyCaseFunName n _) = MatchName $ show n +instance PShow TyCaseFunName where pShow (TyCaseFunName n _) = text $ MatchName $ show n + +-------------------------------------------------------------------------------- core expression representation + +data Freq = CompileTime | RunTime -- TODO + deriving (Eq) + +data Exp + = ELit Lit + | TType_ Freq + | Lam_ FreeVars Exp + | Con_ FreeVars ConName !Int{-number of ereased arguments applied-} [Exp]{-args reversed-} + | TyCon_ FreeVars TyConName [Exp]{-args reversed-} + | Pi_ FreeVars Visibility Exp Exp + | Neut Neutral + | RHS Exp{-always in hnf-} + | Let_ FreeVars ExpType Exp + | Up_ FreeVars [Int] Exp + +data Neutral + = Var_ !Int{-De Bruijn index-} + | App__ FreeVars Neutral Exp + | CaseFun__ FreeVars CaseFunName [Exp] Neutral + | TyCaseFun__ FreeVars TyCaseFunName [Exp] Neutral + | Fun_ FreeVars FunName [Exp]{-given parameters, reversed-} Exp{-unfolded expression, in hnf-} + | UpN_ FreeVars [Int] Neutral + +-------------------------------------------------------------------------------- auxiliary functions and patterns + +type Type = Exp + +data ExpType = ET {expr :: Exp, ty :: Type} + deriving (Eq) +{- +pattern ET a b <- ET_ a b + where ET a b = ET_ a (hnf b) +-} +instance Rearrange ExpType where + rearrange l f (ET e t) = ET (rearrange l f e) (rearrange l f t) + +instance HasFreeVars ExpType where + getFreeVars (ET a b) = getFreeVars a <> getFreeVars b + +instance PShow ExpType where pShow = mkDoc (False, False) + +type SExp2 = SExp' ExpType + +setMaxDB db = \case + Neut (Fun_ _ a b c) -> Neut $ Fun_ db a b c + +pattern TType = TType_ CompileTime + +infixl 2 `App`, `app_` +infixr 1 :~> + +pattern NoRHS <- (isRHS -> False) + +isRHS RHS{} = True +isRHS _ = False + +pattern Fun f xs n <- Fun_ _ f xs n + where Fun f xs n = Fun_ (foldMap getFreeVars xs) f xs n +pattern CaseFun_ a b c <- CaseFun__ _ a b c + where CaseFun_ a b c = CaseFun__ (getFreeVars c <> foldMap getFreeVars b) a b c +pattern TyCaseFun_ a b c <- TyCaseFun__ _ a b c + where TyCaseFun_ a b c = TyCaseFun__ (foldMap getFreeVars b <> getFreeVars c) a b c +pattern App_ a b <- App__ _ a b + where App_ a b = App__ (getFreeVars a <> getFreeVars b) a b +pattern Con x n y <- Con_ _ x n y + where Con x n y = Con_ (foldMap getFreeVars y) x n y +pattern TyCon x y <- TyCon_ _ x y + where TyCon x y = TyCon_ (foldMap getFreeVars y) x y +pattern Lam y <- Lam_ _ y + where Lam y = Lam_ (lowerFreeVars (getFreeVars y)) y +pattern Pi v x y <- Pi_ _ v x y + where Pi v x y = Pi_ (getFreeVars x <> lowerFreeVars (getFreeVars y)) v x y +pattern Let x y <- Let_ _ x y + where Let x y = Let_ (getFreeVars x <> lowerFreeVars (getFreeVars y)) x y + +pattern SubstLet x <- (substLet -> Just x) + +substLet (Let x y) = Just $ subst 0 (expr x) y +substLet _ = Nothing + +pattern CaseFun a b c = Neut (CaseFun_ a b c) +pattern TyCaseFun a b c = Neut (TyCaseFun_ a b c) +pattern Var a = Neut (Var_ a) +pattern App a b <- Neut (App_ (Neut -> a) b) +pattern DFun a b = Neut (DFunN a b) +pattern DFun_ s a b = Neut (DFunN_ s a b) + +-- unreducable function application +pattern UFun a b <- Neut (Fun (FunName (FTag a) _ _ _) b NoRHS) + +-- saturated function application +pattern DFunN a xs <- Fun (FunName (FTag a) _ _ _) xs _ + where DFunN a xs = Fun (mkFunDef' (FTag a)) xs delta + +pattern DFunN_ s a xs <- Fun_ s (FunName (FTag a) _ _ _) xs _ + where DFunN_ s a xs = Fun_ s (mkFunDef' (FTag a)) xs delta + +mkFunDef' a@(FTag f) = mkFunDef a $ funTy f + +funTy = \case + F'EqCT -> TType :~> Var 0 :~> Var 1 :~> TConstraint + Fcoe -> TType :~> TType :~> CW (CstrT TType (Var 1) (Var 0)) :~> Var 2 :~> Var 2 + FparEval -> TType :~> Var 0 :~> Var 1 :~> Var 2 + F'T2 -> TConstraint :~> TConstraint :~> TConstraint + F'CW -> TConstraint :~> TType + Ft2C -> Unit :~> Unit :~> Unit + +conParams (conTypeName -> TyConName _ _ _ _ (CaseFunName _ _ pars)) = pars +mkConPars n (snd . getParams . hnf -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) = take (min n pars) $ reverse xs +mkConPars n x@Neut{} = error $ "mkConPars!: " ++ ppShow x +mkConPars n x = error $ "mkConPars: " ++ ppShow (n, x) + +pattern ConN s a <- Con (ConName (FTag s) _ _) _ a +tCon s i t a = Con (ConName (FTag s) i t) 0 a +tCon_ k s i t a = Con (ConName (FTag s) i t) k a +pattern TyConN s a <- TyCon (TyConName s _ _ _ _) a + +pattern TTyCon0 s <- TyCon (TyConName (FTag s) _ _ _ _) [] +tTyCon0 s cs = TyCon (TyConName (FTag s) 0 TType (map ((,) (error "tTyCon0")) cs) $ CaseFunName (error "TTyCon0-A") (error "TTyCon0-B") 0) [] + +pattern a :~> b = Pi Visible a b + +delta = ELit (LString "<>") -- TODO: build an error call + +pattern TConstraint <- TTyCon0 F'Constraint where TConstraint = tTyCon0 F'Constraint $ error "cs 1" +pattern Unit <- TTyCon0 F'Unit where Unit = tTyCon0 F'Unit [Unit] +pattern TInt <- TTyCon0 F'Int where TInt = tTyCon0 F'Int $ error "cs 1" +pattern TNat <- TTyCon0 F'Nat where TNat = tTyCon0 F'Nat $ error "cs 3" +pattern TBool <- TTyCon0 F'Bool where TBool = tTyCon0 F'Bool $ error "cs 4" +pattern TFloat <- TTyCon0 F'Float where TFloat = tTyCon0 F'Float $ error "cs 5" +pattern TString <- TTyCon0 F'String where TString = tTyCon0 F'String $ error "cs 6" +pattern TChar <- TTyCon0 F'Char where TChar = tTyCon0 F'Char $ error "cs 7" +pattern TOrdering <- TTyCon0 F'Ordering where TOrdering = tTyCon0 F'Ordering $ error "cs 8" +pattern TVec a b <- TyConN (FTag F'VecS) [a, b] + +pattern Empty s <- TyCon (TyConName (FTag F'Empty) _ _ _ _) (HString{-hnf?-} s: _) + where Empty s = TyCon (TyConName (FTag F'Empty) (error "todo: inum2_") (TString :~> TType) (error "todo: tcn cons 3_") $ error "Empty") [HString s] + +pattern TT <- Con _ _ _ + where TT = tCon FTT 0 Unit [] + +pattern CUnit <- ConN FCUnit _ + where CUnit = tCon FCUnit 0 TConstraint [] +pattern CEmpty s <- ConN FCEmpty (HString s: _) + where CEmpty s = tCon FCEmpty 1 (TString :~> TConstraint) [HString s] + +pattern CstrT t a b = Neut (CstrT' t a b) +pattern CstrT' t a b = DFunN F'EqCT [b, a, t] +pattern Coe a b w x = DFun Fcoe [x,w,b,a] +pattern ParEval t a b = DFun FparEval [b, a, t] +pattern T2 s a b = DFun_ s F'T2 [b, a] +pattern CW a = DFun F'CW [a] +pattern CW_ s a = DFun_ s F'CW [a] +pattern CSplit a b c <- UFun F'Split [c, b, a] + +pattern HLit a <- (hnf -> ELit a) + where HLit = ELit +pattern HInt a = HLit (LInt a) +pattern HFloat a = HLit (LFloat a) +pattern HChar a = HLit (LChar a) +pattern HString a = HLit (LString a) + +pattern EBool a <- (getEBool -> Just a) + where EBool = \case + False -> tCon FFalse 0 TBool [] + True -> tCon FTrue 1 TBool [] + +getEBool (hnf -> ConN FFalse _) = Just False +getEBool (hnf -> ConN FTrue _) = Just True +getEBool _ = Nothing + +pattern ENat n <- (fromNatE -> Just n) + where ENat 0 = tCon FZero 0 TNat [] + ENat n | n > 0 = tCon FSucc 1 (TNat :~> TNat) [ENat (n-1)] + +fromNatE :: Exp -> Maybe Int +fromNatE (hnf -> ConN FZero _) = Just 0 +fromNatE (hnf -> ConN FSucc (n: _)) = succ <$> fromNatE n +fromNatE _ = Nothing + +mkOrdering x = 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 + +mkFun_ md (FunName _ _ (DeltaDef ar f) _) as _ | length as == ar = f md as +mkFun_ md f@(FunName _ _ (ExpDef e) _) xs _ = Neut $ Fun_ md f xs $ hnf $ foldlrev app_ e xs +mkFun_ md f xs y = Neut $ Fun_ md f xs $ hnf y + +mkFun :: FunName -> [Exp] -> Exp -> Exp +mkFun f xs e = mkFun_ (foldMap getFreeVars xs) f xs e + +pattern ReducedN y <- Fun _ _ (RHS y) +pattern Reduced y <- Neut (ReducedN y) +{- +-- TODO: too much hnf call +reduce (Neut (ReducedN y)) = Just $ hnf y +reduce (SubstLet x) = Just $ hnf x +reduce _ = Nothing +-} +hnf (Reduced y) = hnf y -- TODO: review hnf call here +hnf a = a + +outputType = tTyCon0 F'Output $ error "cs 9" + +-- TODO: remove +boolType = TBool +-- TODO: remove +trueExp = EBool True + +-------------------------------------------------------------------------------- low-level toolbox + +class Subst b a where + subst_ :: Int -> FreeVars -> b -> a -> a + +--subst :: Subst b a => Int -> FreeVars -> b -> a -> a +subst i x a = subst_ i (getFreeVars x) x a + +instance Subst Exp ExpType where + subst_ i dx x (ET a b) = ET (subst_ i dx x a) (subst_ i dx x b) + +instance Subst ExpType SExp2 where + subst_ j _ x = mapS (\_ _ -> error "subst: TODO") (const . SGlobal) f2 0 + where + f2 sn i k = case compare i (k + j) of + GT -> SVar sn $ i - 1 + LT -> SVar sn i + EQ -> STyped $ up k x + +down :: (PShow a, Subst Exp a, HasFreeVars a{-usedVar-}) => Int -> a -> Maybe a +down t x | usedVar t x = Nothing + | otherwise = Just $ subst_ t mempty (error $ "impossible: down" ++ ppShow (t,x, getFreeVars x) :: Exp) x + +instance Eq Exp where + Neut a == Neut a' = a == a' -- try to compare by structure before reduction + Reduced a == a' = a == a' + a == Reduced 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_ f == TType_ f' = f == f' + ELit l == ELit l' = l == l' + RHS a == RHS a' = a == a' + _ == _ = False + +instance Eq Neutral where + Fun f a _ == Fun f' a' _ = (f, a) == (f', a') -- try to compare by structure before reduction + ReducedN a == a' = a == Neut a' + a == ReducedN a' = Neut 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 + +instance Subst Exp Exp where + subst_ i0 dx x = f i0 + where + f i (Neut n) = substNeut n + where + substNeut e | dbGE 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__ fs s as n -> evalCaseFun (adjustDB i fs) s (f i <$> as) (substNeut n) + TyCaseFun__ fs s as n -> evalTyCaseFun_ (adjustDB i fs) s (f i <$> as) (substNeut n) + App__ fs a b -> app__ (adjustDB i fs) (substNeut a) (f i b) + Fun_ md fn xs v -> mkFun_ (adjustDB i md) fn (f i <$> xs) $ f i v + f i e | dbGE i e = e + f i e = case e of + Lam_ md b -> Lam_ (adjustDB i md) (f (i+1) b) + Con_ md s n as -> Con_ (adjustDB i md) s n $ f i <$> as + Pi_ md h a b -> Pi_ (adjustDB i md) h (f i a) (f (i+1) b) + TyCon_ md s as -> TyCon_ (adjustDB i md) s $ f i <$> as + Let_ md a b -> Let_ (adjustDB i md) (subst_ i dx x a) (f (i+1) b) + RHS a -> RHS $ hnf $ f i a + x -> x + + adjustDB i md = if usedVar i md then delVar i md <> shiftFreeVars (i-i0) dx else delVar i md + +instance Rearrange Exp where + rearrange i g = f i where + f i e | dbGE i e = e + f i e = case e of + Lam_ md b -> Lam_ (rearrangeFreeVars g i md) (f (i+1) b) + Pi_ md h a b -> Pi_ (rearrangeFreeVars g i md) h (f i a) (f (i+1) b) + Con_ md s pn as -> Con_ (rearrangeFreeVars g i md) s pn $ map (f i) as + TyCon_ md s as -> TyCon_ (rearrangeFreeVars g i md) s $ map (f i) as + Neut x -> Neut $ rearrange i g x + Let x y -> Let (rearrange i g x) (rearrange (i+1) g y) + RHS x -> RHS $ rearrange i g x + +instance Rearrange Neutral where + rearrange i g = f i where + f i e | dbGE i e = e + f i e = case e of + Var_ k -> Var_ $ if k >= i then rearrangeFun g (k-i) + i else k + CaseFun__ md s as ne -> CaseFun__ (rearrangeFreeVars g i md) s (rearrange i g <$> as) (rearrange i g ne) + TyCaseFun__ md s as ne -> TyCaseFun__ (rearrangeFreeVars g i md) s (rearrange i g <$> as) (rearrange i g ne) + App__ md a b -> App__ (rearrangeFreeVars g i md) (rearrange i g a) (rearrange i g b) + Fun_ md fn x y -> Fun_ (rearrangeFreeVars g i md) fn (rearrange i g <$> x) $ rearrange i g y + +instance HasFreeVars Exp where + getFreeVars = \case + Lam_ c _ -> c + Pi_ c _ _ _ -> c + Con_ c _ _ _ -> c + TyCon_ c _ _ -> c + Let_ c _ _ -> c + + TType_ _ -> mempty + ELit{} -> mempty + Neut x -> getFreeVars x + RHS x -> getFreeVars x + +instance HasFreeVars Neutral where + getFreeVars = \case + Var_ k -> freeVar k + CaseFun__ c _ _ _ -> c + TyCaseFun__ c _ _ _ -> c + App__ c a b -> c + Fun_ c _ _ _ -> c + +varType' :: Int -> [Exp] -> Exp +varType' i vs = vs !! i + +-------------------------------------------------------------------------------- pretty print + +instance PShow Exp where + pShow = mkDoc (False, False) + +instance PShow Neutral where + pShow = mkDoc (False, False) + +class MkDoc a where + mkDoc :: (Bool {-print reduced-}, Bool{-print function bodies-}) -> a -> Doc + +instance MkDoc ExpType where + mkDoc pr (ET e TType) = mkDoc pr e + mkDoc pr (ET e t) = DAnn (mkDoc pr e) (mkDoc pr t) + +instance MkDoc Exp where + mkDoc pr@(reduce, body) = \case + Lam b -> shLam_ (usedVar' 0 b "") (BLam Visible) Nothing (mkDoc pr b) + Pi h TType b -> shLam_ (usedVar' 0 b "") (BPi h) Nothing (mkDoc pr b) + Pi h a b -> shLam (usedVar' 0 b "") (BPi h) (mkDoc pr a) (mkDoc pr b) + ENat n -> pShow n + Con s@(ConName _ i _) _ _ | body -> text $ "<<" ++ showNth i ++ " constructor of " ++ show (conTypeName s) ++ ">>" + ConN FHCons (xs: x: _{-2-}) -> foldl DApp (text "HCons") (mkDoc pr <$> [x, xs]) + Con s _ xs -> foldlrev DApp (pShow s) (mkDoc pr <$> xs) + TyCon s@(TyConName _ i _ cs _) _ | body + -> text $ "< cs) ++ ">>" + TyConN s xs -> foldlrev DApp (pShow s) (mkDoc pr <$> xs) + TType -> text "Type" + ELit l -> pShow l + Neut x -> mkDoc pr x + Let a b -> shLet_ (pShow a) (pShow b) + RHS x -> text "_rhs" `DApp` mkDoc pr x + +pattern FFix f <- Fun (FunName (FTag FprimFix) _ _ _) [f, _] _ + +getFixLam (Lam (Neut (Fun s@(FunName _ loc _ _) xs _))) + | loc > 0 + , (h, v) <- splitAt loc $ reverse xs + , Neut (Var_ 0) <- last h + = Just (s, v) +getFixLam _ = Nothing + +instance MkDoc Neutral where + mkDoc pr@(reduce, body) = \case + CstrT' t a b -> shCstr (mkDoc pr a) (mkDoc pr (ET b t)) + Fun (FunName _ _ (ExpDef d) _) xs _ | body -> mkDoc (reduce, False) (foldlrev app_ d xs) + FFix (getFixLam -> Just (s, xs)) | not body -> foldl DApp (pShow s) $ mkDoc pr <$> xs + FFix f {- | body -} -> foldl DApp "primFix" [{-pShow t -}"_", mkDoc pr f] + Fun (FunName _ _ (DeltaDef n _) _) _ _ | body -> text $ "<>" + Fun (FunName _ _ NoDef _) _ _ | body -> "<>" + ReducedN a | reduce -> mkDoc pr a + Fun s@(FunName _ loc _ _) xs _ -> foldl DApp ({-foldl DHApp (-}pShow s{-) h-}) v + where (_h, v) = splitAt loc $ mkDoc pr <$> reverse xs + Var_ k -> shVar k + App_ a b -> mkDoc pr a `DApp` mkDoc pr b + CaseFun_ s@(CaseFunName _ _ p) _ n | body -> text $ "<>" + CaseFun_ s xs n -> foldl DApp (pShow s) (map (mkDoc pr) $ xs ++ [Neut n]) + TyCaseFun_ _ _ _ | body -> text "<>" + TyCaseFun_ s [m, t, f] n -> foldl DApp (pShow s) (mkDoc pr <$> [m, t, Neut n, f]) + TyCaseFun_ s _ n -> error $ "mkDoc TyCaseFun" + _ -> "()" + +-------------------------------------------------------------------------------- reduction + +{- 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 +-} + +mkFunDef a@(FTag FprimFix) t = fn + where + fn = FunName a 0 (DeltaDef 2 fx) t + fx s xs@(f: _) = x where x = Neut $ Fun_ s fn xs $ RHS $ f `app_` x + +mkFunDef a@(FTag tag) t = fn + where + fn = FunName a 0 (maybe NoDef (DeltaDef (length $ fst $ getParams t)) $ getFunDef tag) t + + getFunDef tag = case tag of + F'EqCT -> Just $ \s -> \case (b: a: t: _) -> cstr t a b + F'T2 -> Just $ \s -> \case (b: a: _) -> t2_ s a b + F'CW -> Just $ \s -> \case (a: _) -> cw_ s a + Ft2C -> Just $ \s -> \case (b: a: _) -> t2C a b + Fcoe -> Just $ \s -> \case (d: t: b: a: _) -> evalCoe a b t d + FparEval -> Just $ \s -> \case (b: a: t: _) -> parEval t a b + where + parEval _ x@RHS{} _ = x + parEval _ _ x@RHS{} = x + parEval t a b = ParEval t a b + + FunsafeCoerce -> Just $ \s -> \case xs@(x@(hnf -> NonNeut): _{-2-}) -> x; xs -> f s xs + FreflCstr -> Just $ \s -> \case _ -> TT + FhlistNilCase -> Just $ \s -> \case ((hnf -> Con n@(ConName _ 0 _) _ _): x: _{-1-}) -> x; xs -> f s xs + FhlistConsCase -> Just $ \s -> \case ((hnf -> Con n@(ConName _ 1 _) _ (b: a: _{-2-})): x: _{-3-}) -> x `app_` a `app_` b; xs -> f s xs + + -- general compiler primitives + FprimAddInt -> Just $ \s -> \case (HInt j: HInt i: _) -> HInt (i + j); xs -> f s xs + FprimSubInt -> Just $ \s -> \case (HInt j: HInt i: _) -> HInt (i - j); xs -> f s xs + FprimModInt -> Just $ \s -> \case (HInt j: HInt i: _) -> HInt (i `mod` j); xs -> f s xs + FprimSqrtFloat -> Just $ \s -> \case (HFloat i: _) -> HFloat $ sqrt i; xs -> f s xs + FprimRound -> Just $ \s -> \case (HFloat i: _) -> HInt $ round i; xs -> f s xs + FprimIntToFloat -> Just $ \s -> \case (HInt i: _) -> HFloat $ fromIntegral i; xs -> f s xs + FprimIntToNat -> Just $ \s -> \case (HInt i: _) -> ENat $ fromIntegral i; xs -> f s xs + FprimCompareInt -> Just $ \s -> \case (HInt y: HInt x: _) -> mkOrdering $ x `compare` y; xs -> f s xs + FprimCompareFloat -> Just $ \s -> \case (HFloat y: HFloat x: _) -> mkOrdering $ x `compare` y; xs -> f s xs + FprimCompareChar -> Just $ \s -> \case (HChar y: HChar x: _) -> mkOrdering $ x `compare` y; xs -> f s xs + FprimCompareString -> Just $ \s -> \case (HString y: HString x: _) -> mkOrdering $ x `compare` y; xs -> f s xs + + -- LambdaCube 3D specific primitives + FPrimGreaterThan -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (>) x y -> r; xs -> f s xs + FPrimGreaterThanEqual + -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (>=) x y -> r; xs -> f s xs + FPrimLessThan -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (<) x y -> r; xs -> f s xs + FPrimLessThanEqual -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (<=) x y -> r; xs -> f s xs + FPrimEqualV -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (==) x y -> r; xs -> f s xs + FPrimNotEqualV -> Just $ \s -> \case (y: x: _{-7-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f s xs + FPrimEqual -> Just $ \s -> \case (y: x: _{-3-}) | Just r <- twoOpBool (==) x y -> r; xs -> f s xs + FPrimNotEqual -> Just $ \s -> \case (y: x: _{-3-}) | Just r <- twoOpBool (/=) x y -> r; xs -> f s xs + FPrimSubS -> Just $ \s -> \case (y: x: _{-4-}) | Just r <- twoOp (-) x y -> r; xs -> f s xs + FPrimSub -> Just $ \s -> \case (y: x: _{-2-}) | Just r <- twoOp (-) x y -> r; xs -> f s xs + FPrimAddS -> Just $ \s -> \case (y: x: _{-4-}) | Just r <- twoOp (+) x y -> r; xs -> f s xs + FPrimAdd -> Just $ \s -> \case (y: x: _{-2-}) | Just r <- twoOp (+) x y -> r; xs -> f s xs + FPrimMulS -> Just $ \s -> \case (y: x: _{-4-}) | Just r <- twoOp (*) x y -> r; xs -> f s xs + FPrimMul -> Just $ \s -> \case (y: x: _{-2-}) | Just r <- twoOp (*) x y -> r; xs -> f s xs + FPrimDivS -> Just $ \s -> \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f s xs + FPrimDiv -> Just $ \s -> \case (y: x: _{-5-}) | Just r <- twoOp_ (/) div x y -> r; xs -> f s xs + FPrimModS -> Just $ \s -> \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f s xs + FPrimMod -> Just $ \s -> \case (y: x: _{-5-}) | Just r <- twoOp_ modF mod x y -> r; xs -> f s xs + FPrimNeg -> Just $ \s -> \case (x: _{-1-}) | Just r <- oneOp negate x -> r; xs -> f s xs + FPrimAnd -> Just $ \s -> \case (EBool y: EBool x: _) -> EBool (x && y); xs -> f s xs + FPrimOr -> Just $ \s -> \case (EBool y: EBool x: _) -> EBool (x || y); xs -> f s xs + FPrimXor -> Just $ \s -> \case (EBool y: EBool x: _) -> EBool (x /= y); xs -> f s xs + FPrimNot -> Just $ \s -> \case (EBool x: _: _: (hnf -> TNat): _) -> EBool $ not x; xs -> f s xs + + _ -> Nothing + + f s xs = Neut $ Fun_ s fn xs delta + + twoOpBool :: (forall a . Ord a => a -> a -> Bool) -> Exp -> Exp -> Maybe Exp + twoOpBool f (HFloat x) (HFloat y) = Just $ EBool $ f x y + twoOpBool f (HInt x) (HInt y) = Just $ EBool $ f x y + twoOpBool f (HString x) (HString y) = Just $ EBool $ f x y + twoOpBool f (HChar x) (HChar y) = Just $ EBool $ f x y + twoOpBool f (ENat x) (ENat y) = Just $ EBool $ f x y + twoOpBool _ _ _ = Nothing + + oneOp :: (forall a . Num a => a -> a) -> Exp -> Maybe Exp + oneOp f = oneOp_ f f + + oneOp_ f _ (HFloat x) = Just $ HFloat $ f x + oneOp_ _ f (HInt x) = Just $ HInt $ f x + oneOp_ _ _ _ = Nothing + + twoOp :: (forall a . Num a => a -> a -> a) -> Exp -> Exp -> Maybe Exp + twoOp f = twoOp_ f f + + twoOp_ f _ (HFloat x) (HFloat y) = Just $ HFloat $ f x y + twoOp_ _ f (HInt x) (HInt y) = Just $ HInt $ f x y + twoOp_ _ _ _ _ = Nothing + + modF x y = x - fromIntegral (floor (x / y)) * y + +mkFunDef a t = FunName a 0 NoDef t + + +evalCaseFun _ a ps (Con n@(ConName _ i _) _ vs) + | i /= (-1) = foldlrev app_ (ps !!! (i + 1)) vs + | otherwise = error "evcf" + where + xs !!! i | i >= length xs = error $ "!!! " ++ ppShow a ++ " " ++ show i ++ " " ++ ppShow n ++ "\n" ++ ppShow ps + xs !!! i = xs !! i +evalCaseFun fs a b (Reduced c) = evalCaseFun fs a b c +evalCaseFun fs a b (Neut c) = Neut $ CaseFun__ fs a b c +evalCaseFun _ a b x = error $ "evalCaseFun: " ++ ppShow (a, x) + +evalCaseFun' a b c = evalCaseFun (getFreeVars c <> foldMap getFreeVars b) a b c + +evalTyCaseFun a b c = evalTyCaseFun_ (foldMap getFreeVars b <> getFreeVars c) a b c + +evalTyCaseFun_ s a b (Reduced c) = evalTyCaseFun_ s a b c +evalTyCaseFun_ s a b (Neut c) = Neut $ TyCaseFun__ s a b c +evalTyCaseFun_ _ (TyCaseFunName (FTag F'Type) ty) (_: t: f: _) TType = t +evalTyCaseFun_ _ (TyCaseFunName n ty) (_: t: f: _) (TyCon (TyConName n' _ _ _ _) vs) | n == n' = foldlrev 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 (Reduced x) d = evalCoe a b x d +evalCoe a b TT d = d +evalCoe a b t d = Coe a b t d + +cstr_ t a b = cw $ cstr t a b + +cstr = f [] + where + f z ty a a' = f_ z (hnf ty) (hnf a) (hnf a') + + f_ _ _ a a' | a == a' = CUnit + f_ ns typ (RHS a) (RHS 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) $ reverse $ zip xs xs' + f_ ns typ (TyCon a xs) (TyCon a' xs') | a == a' && length xs == length xs' = + ff ns (nType a) $ reverse $ 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 (UFun F'VecScalar [b, a]) (UFun F'VecScalar [b', a']) = t2 (f [] TNat a a') (f [] TType b b') + f_ [] TType (UFun F'VecScalar [b, a]) (TVec a' b') = t2 (f [] TNat a a') (f [] TType b b') + f_ [] TType (UFun F'VecScalar [b, a]) t@NonNeut = t2 (f [] TNat a (ENat 1)) (f [] TType b t) + f_ [] TType (TVec a' b') (UFun F'VecScalar [b, a]) = t2 (f [] TNat a' a) (f [] TType b' b) + f_ [] TType t@NonNeut (UFun F'VecScalar [b, a]) = 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' = CEmpty $ simpleShow $ nest 2 ("can not unify" <$$> DTypeNamespace True (pShow a)) <$$> nest 2 ("with" <$$> DTypeNamespace True (pShow a')) + + ff _ _ [] = CUnit + 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 Neut{} = False +nonNeut _ = True + +t2C (hnf -> TT) (hnf -> TT) = TT +t2C a b = DFun Ft2C [b, a] + +cw_ _ (hnf -> CUnit) = Unit +cw_ _ (hnf -> CEmpty a) = Empty a +cw_ s a = CW_ s a + +cw a = cw_ (getFreeVars a) a + +t2_ _ (hnf -> CUnit) a = a +t2_ _ a (hnf -> CUnit) = a +t2_ _ (hnf -> CEmpty a) (hnf -> CEmpty b) = CEmpty (a <> b) +t2_ _ (hnf -> CEmpty s) _ = CEmpty s +t2_ _ _ (hnf -> CEmpty s) = CEmpty s +t2_ s a b = T2 s a b + +t2 a b = t2_ (getFreeVars a <> getFreeVars b) a b + +app_ :: Exp -> Exp -> Exp +app_ a b = app__ (getFreeVars a <> getFreeVars b) a b + +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 (a: xs) +app__ _ (TyCon s xs) a = TyCon s (a: xs) +app__ _ (SubstLet f) a = app_ f a +app__ s (Neut f) a = neutApp f a + where + neutApp (ReducedN x) a = app_ x a + neutApp (Fun_ db f xs (Lam e)) a = mkFun_ (db <> getFreeVars a) f (a: xs) (subst 0 a e) + neutApp f a = Neut $ App__ s f a + +conType (snd . getParams . hnf -> TyCon (TyConName _ _ _ cs _) _) (ConName _ n t) = t --snd $ cs !! n + +appTy (Pi _ a b) x = subst 0 x b +appTy t x = error $ "appTy: " ++ ppShow t + +getParams :: Exp -> ([(Visibility, Exp)], Exp) +getParams (Pi h a b) = first ((h, a):) $ getParams b +getParams x = ([], x) + +--------------------------------------------------------- evident types + +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 + +instance NType Lit where + nType = \case + LInt _ -> TInt + LFloat _ -> TFloat + LString _ -> TString + LChar _ -> TChar + + 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 @@ -30,16 +30,18 @@ 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 LambdaCube.Compiler.DeBruijn as I +import LambdaCube.Compiler.DesugaredSource hiding (getTTuple) +import LambdaCube.Compiler.Core (Subst(..), down, nType) +import qualified LambdaCube.Compiler.Core as I +import LambdaCube.Compiler.Infer (neutType', makeCaseFunPars') import Data.Version import Paths_lambdacube_compiler (version) -------------------------------------------------------------------------- -compilePipeline :: IR.Backend -> ExpType -> IR.Pipeline +compilePipeline :: IR.Backend -> I.ExpType -> IR.Pipeline compilePipeline backend exp = IR.Pipeline { IR.info = "generated by lambdacube-compiler " ++ showVersion version , IR.backend = backend @@ -89,7 +91,10 @@ 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 + (vertexInput, pUniforms, vertSrc, fragSrc) = case backend of + -- disabled DX11 codegen, due to it's incomplete + --IR.DirectX11 -> genHLSLs backend (compRC' rctx) ints vert frag ffilter + _ -> genGLSLs backend (compRC' rctx) ints vert frag ffilter pUniforms' = snd <$> Map.filter ((\case UTexture2D{} -> False; _ -> True) . fst) pUniforms @@ -223,7 +228,7 @@ compSemantics = map compSemantic . compList -compList (A2 "Cons" a x) = a : compList x +compList (A2 ":" a x) = a : compList x compList (A0 "Nil") = [] compList x = error $ "compList: " ++ ppShow x @@ -573,7 +578,7 @@ 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 + | otherwise = error $ "makeSubst illegal input " ++ err ++ " " ++ ppShow ps ++ "\n" ++ ppShow vertOuts noUnit TTuple0 = False noUnit _ = True @@ -620,7 +625,6 @@ = UUniform | UTexture2DSlot | UTexture2D Integer Integer ExpTV - deriving (Show) type Uniforms = Map String (Uniform, IR.InputType) @@ -635,7 +639,7 @@ 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 + ELit a -> pure $ pShow 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 @@ -726,7 +730,6 @@ "RoundEven" -> "roundEven" "ModF" -> error "PrimModF is not implemented yet!" -- TODO "MixB" -> "mix" - n | n `elem` -- Logic Functions [ "Any", "All" @@ -735,7 +738,7 @@ -- Exponential Functions , "Pow", "Exp", "Exp2", "Log2", "Sqrt" -- Common Functions - , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Step", "SmoothStep" + , "IsNan", "IsInf", "Abs", "Sign", "Floor", "Trunc", "Round", "Ceil", "Fract", "Min", "Max", "Mix", "Clamp", "Step", "SmoothStep" -- Geometric Functions , "Length", "Distance", "Dot", "Cross", "Normalize", "FaceForward", "Reflect", "Refract" -- Matrix Functions @@ -818,8 +821,8 @@ -------------------------------------------------------------------------------- -- expression + type + type of local variables -data ExpTV = ExpTV_ Exp Exp [Exp] - deriving (Show, Eq) +data ExpTV = ExpTV_ I.Exp I.Exp [I.Exp] + deriving (Eq) pattern ExpTV a b c <- ExpTV_ a b c where ExpTV a b c = ExpTV_ (a) (unLab' b) c @@ -832,15 +835,15 @@ mapVal f (ExpTV a b c) = ExpTV (f a) b c -toExp :: ExpType -> ExpTV -toExp (x, xt) = ExpTV x xt [] +toExp :: I.ExpType -> ExpTV +toExp (I.ET 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 ELit l <- ExpTV (unLab' -> I.ELit l) _ _ pattern TType <- ExpTV (unLab' -> I.TType) _ _ pattern Func fn def ty xs <- (mkFunc -> Just (fn, def, ty, xs)) @@ -860,66 +863,78 @@ 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 (ExpTV (I.Con s n (reverse -> xs)) et vs) = Just (untick $ show s, chain vs (I.conType et s) $ I.mkConPars n et ++ xs) +mkCon (ExpTV (I.TyCon s (reverse -> xs)) et vs) = Just (untick $ show s, chain vs (nType s) xs) +mkCon (ExpTV (I.Neut (I.Fun s@(I.FunName _ loc _{-I.DeltaDef{}-} _) (reverse -> xs) def)) et vs) = Just (untick $ show s, drop loc $ chain vs (nType s) xs) +mkCon (ExpTV (I.CaseFun s xs n) et vs) = Just (untick $ show s, chain vs (nType s) $ makeCaseFunPars' (mkEnv vs) n ++ xs ++ [I.Neut n]) +mkCon (ExpTV (I.TyCaseFun s [m, t, f] n) et vs) = Just (untick $ show s, chain vs (nType s) [m, t, I.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]) +mkApp (ExpTV (I.Neut (I.App_ a b)) et vs) = Just (ExpTV (I.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') +removeRHS 0 (I.RHS x) = Just x +removeRHS n (I.Lam x) | n > 0 = I.Lam <$> removeRHS (n-1) x +removeRHS _ _ = Nothing + +mkFunc r@(ExpTV (I.Neut (I.Fun (I.FunName (show -> n) loc (I.ExpDef def_) nt) xs I.RHS{})) ty vs) + | Just def <- removeRHS (length xs) def_ + , all (supType . tyOf) (r: xs') && n `notElem` ["typeAnn"] && all validChar n + = Just (untick n +++ intercalate "_" (filter (/="TT") $ map (filter isAlphaNum . plainShow . shortForm . pShow) hs), toExp $ I.ET (foldl I.app_ def hs) (foldl I.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 + (map (expOf . snd) -> hs, map snd -> xs') = splitAt loc $ chain' vs nt $ reverse xs validChar = isAlphaNum +{- +mkFunc r@(ExpTV (I.Neut (I.Fun (I.FunName (show -> n) loc (I.ExpDef def_) nt) xs I.RHS{})) ty vs) + | Just def <- removeRHS (length xs) def_ + , all validChar n + = tracePShow (text n, reverse xs, supType . tyOf <$> (r: xs')) Nothing + where + a +++ [] = a + a +++ b = a ++ "_" ++ b + (map (expOf . snd) -> hs, map snd -> xs') = splitAt loc $ chain' vs nt $ reverse xs + validChar = isAlphaNum +mkFunc r@(ExpTV (I.Neut (I.Fun (I.FunName (show -> n) loc (I.ExpDef def_) nt) xs I.RHS{})) ty vs) + = tracePShow (text n, take loc $ reverse xs) Nothing +-} mkFunc _ = Nothing -chain vs t@(I.Pi Hidden at y) (a: as) = chain vs (appTy t a) as +chain vs t@(I.Pi Hidden at y) (a: as) = chain vs (I.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 +chain' vs t@(I.Pi b at y) (a: as) = (b, ExpTV a at vs): chain' vs (I.appTy t a) as +chain' vs t _ = error $ "chain: " ++ ppShow t mkTVar i (ExpTV t _ vs) = ExpTV (I.Var i) t vs -unLab' (FL x) = unLab' x -unLab' (LabelEnd x) = unLab' x +unLab' (I.Reduced x) = unLab' x +unLab' (I.RHS x) = unLab' x -- TODO: remove unLab' x = x -unFunc' (FL x) = unFunc' x -- todo: remove? -unFunc' (UFL x) = unFunc' x -unFunc' (LabelEnd x) = unFunc' x +unFunc' (I.Reduced x) = unFunc' x -- todo: remove? +unFunc' (I.Neut (I.Fun (I.FunName _ _ I.ExpDef{} _) _ y)) = unFunc' y +unFunc' (I.RHS x) = unFunc' x -- TODO: remove 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) +instance Subst I.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) (I.shiftFreeVars 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 HasFreeVars ExpTV where + getFreeVars (ExpTV x xt vs) = getFreeVars x <> getFreeVars xt instance PShow ExpTV where - pShowPrec p (ExpTV x t _) = pShowPrec p (x, t) + pShow (ExpTV x t _) = pShow (x, t) -isSampler (TyCon n _) = show n == "'Sampler" +isSampler (I.TyCon n _) = show n == "'Sampler" isSampler _ = False -untick ('\'': s) = s -untick s = s - -------------------------------------------------------------------------------- ExpTV conversion -- TODO: remove removeLams 0 x = x @@ -996,3 +1011,363 @@ getTuple (A2 "HCons" x (getTuple -> Just xs)) = Just (x: xs) getTuple _ = Nothing +------------ HLSL DX11 +genHLSL :: [SName] -> ExpTV -> WriterT (Uniforms, Map.Map SName (ExpTV, ExpTV, [ExpTV])) (State [String]) Doc +genHLSL dns e = case e of + + ELit a -> pure $ pShow 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" -> "*" + "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" -> "mul" + "MulVecMat" -> "mul" + "MulMatMat" -> "mul" + + -- 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" -> "float2x2" + "M33F" -> "float3x3" + "M44F" -> "float4x4" + + "==" -> "==" + + n | n `elem` ["primNegateWord", "primNegateInt", "primNegateFloat"] -> "-_" + n | n `elem` ["V2", "V3", "V4"] -> toHLSLType (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 $ "HLSL codegen - unsupported function: " ++ ppShow x + + x -> error $ "HLSL 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 = genHLSL 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 + +genHLSLs 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 $ + ["cbuffer cbuf {"] + <> uniformDecls vertUniforms -- non texture uniforms + <> ["};"] + <> ["struct VS_IN {"] + <> [shaderDecl' (text t) (text n) | (n, t) <- zip vertInNames vertIns] + <> ["};"] + <> ["struct PS_IN {"] + <> vertOutDecls "" + <> ["};"] + <> vertFuncs + <> [shaderFunc "PS_IN" "VS" [("VS_IN" <+> "VS_input")] $ + vertVals + <> [shaderLet (text n) x | (n, x) <- zip vertOutNamesWithPosition vertHLSL] + -- <> [shaderLet "gl_PointSize" x | Just x <- [ptHLSL]] + ] + + , -- fragment shader code + shader $ + uniformDecls fragUniforms + <> ["struct PS_IN {"] + <> vertOutDecls "" + <> ["};"] + <> ["struct PS_OUT {"] + <> [shaderDecl' (text t) (text n) | (n, t) <- zip fragOutNames fragOuts, backend == OpenGL33] + <> ["};"] + <> fragFuncs + <> [shaderFunc "PS_OUT" "PS" [("PS_IN" <+> "PS_input")] $ + fragVals + <> [shaderStmt $ "if" <+> parens ("!" <> parens filt) <+> "discard" | Just filt <- [filtHLSL]] + <> [shaderLet (text n) x | (n, x) <- zip fragOutNames fragHLSL ] + ] + ) + where + uniformDecls us = [shaderDecl' (text $ showHLSLType "2" t) (text n) | (n, (_, t)) <- Map.toList us] + vertOutDecls io = [shaderDecl (text i <+> io) (text t) (text n) | (n, (i, t)) <- zip vertOutNames vertOuts] + + fragOutNames = case length frags of + 0 -> [] + 1 -> ["gl_FragColor"] + + (vertIns, verts) = case vert of + Just (etaReds -> Just (xs, ETuple ys)) -> (toHLSLType "3" <$> xs, ys) + Nothing -> ([toHLSLType "4" tvert], [mkTVar 0 tvert]) + + (fragOuts, frags) = case frag of + Just (etaReds -> Just (xs, ETuple ys)) -> (toHLSLType "31" . tyOf <$> ys, ys) + Nothing -> ([toHLSLType "41" tfrag], [mkTVar 0 tfrag]) + + (((vertHLSL, ptHLSL), (vertUniforms, (vertFuncs, vertVals))), ((filtHLSL, fragHLSL), (fragUniforms, (fragFuncs, fragVals)))) = flip evalState shaderNames $ do + ((g1, (us1, verts)), (g2, (us2, frags))) <- (,) + <$> runWriterT ((,) + <$> traverse (genHLSL' "1" vertInNames . (,) vertIns) verts + <*> traverse (genHLSL' "2" vertOutNamesWithPosition . reds) rp) + <*> runWriterT ((,) + <$> traverse (genHLSL' "3" vertOutNames . red) ffilter + <*> traverse (genHLSL' "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 $ genHLSL (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 (toHLSLType "45") tys) (map text funArgs)) + [shaderReturn def]] + , [] + ) + where + ot = toHLSLType "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 + genHLSL' err vertOuts (ps, o) + | length ps == length vertOuts = genHLSL (reverse vertOuts) o + | otherwise = error $ "makeSubst illegal input " ++ err ++ " " ++ ppShow ps ++ "\n" ++ ppShow vertOuts + + noUnit TTuple0 = False + noUnit _ = True + + vertOuts = zipWith go ints $ tail verts + where + go (A0 n) e = (interpName n, toHLSLType "3" $ tyOf e) + + interpName "Smooth" = "smooth" + interpName "Flat" = "flat" + interpName "NoPerspective" = "noperspective" + + shader xs = vcat $ + [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 + +toHLSLType msg x = showHLSLType msg $ compInputType msg x + +-- move to lambdacube-ir? +showHLSLType msg = \case + IR.Bool -> "bool" + IR.Word -> "uint" + IR.Int -> "int" + IR.Float -> "float" + IR.V2F -> "float2" + IR.V3F -> "float3" + IR.V4F -> "float4" + IR.V2B -> "bool2" + IR.V3B -> "bool3" + IR.V4B -> "bool4" + IR.V2U -> "uint2" + IR.V3U -> "uint3" + IR.V4U -> "uint4" + IR.V2I -> "int2" + IR.V3I -> "int3" + IR.V4I -> "int4" + IR.M22F -> "float2x2" + IR.M33F -> "float3x3" + IR.M44F -> "float4x4" + IR.M23F -> "float2x3" + IR.M24F -> "float2x4" + IR.M32F -> "float3x2" + IR.M34F -> "float3x4" + IR.M42F -> "float4x2" + IR.M43F -> "float4x3" + IR.FTexture2D -> "Texture2D" + t -> error $ "toHLSLType: " ++ msg ++ " " ++ show t diff --git a/src/LambdaCube/Compiler/DeBruijn.hs b/src/LambdaCube/Compiler/DeBruijn.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/DeBruijn.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LambdaCube.Compiler.DeBruijn where + +import Data.Bits +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.Pretty + +-------------------------------------------------------------------------------- rearrange De Bruijn indices + +class Rearrange a where + rearrange :: Int{-level-} -> RearrangeFun -> a -> a + +data RearrangeFun + = RFSubst Int Int + | RFMove Int + | RFUp Int + deriving Show + +rearrangeFun = \case + RFSubst i j -> \k -> if k == i then j else if k > i then k - 1 else k + RFMove i -> \k -> if k == i then 0 else k + 1 + RFUp n -> \k -> if k >= 0 then k + n else k + +rSubst :: Rearrange a => Int -> Int -> a -> a +rSubst i j = rearrange 0 $ RFSubst i j + +-- move index to 0 +rMove :: Rearrange a => Int -> Int -> a -> a +rMove i l = rearrange l $ RFMove i + +rUp :: Rearrange a => Int -> Int -> a -> a +rUp n l = rearrange l $ RFUp n + +up1_ :: Rearrange a => Int -> a -> a +up1_ = rUp 1 + +up n = rUp n 0 +up1 = up1_ 0 + +instance Rearrange a => Rearrange [a] where + rearrange l f = map $ rearrange l f + +instance (Rearrange a, Rearrange b) => Rearrange (Either a b) where + rearrange l f = rearrange l f +++ rearrange l f + +instance (Rearrange a, Rearrange b) => Rearrange (a, b) where + rearrange l f = rearrange l f *** rearrange l f + +instance Rearrange Void where + rearrange _ _ = elimVoid + +------------------------------------------------------- set of free variables (implemented with bit vectors) + +newtype FreeVars = FreeVars Integer + deriving Eq + +instance PShow FreeVars where + pShow (FreeVars s) = "FreeVars" `DApp` pShow s + +instance Monoid FreeVars where + mempty = FreeVars 0 + FreeVars a `mappend` FreeVars b = FreeVars $ a .|. b + +freeVar :: Int -> FreeVars +freeVar i = FreeVars $ 1 `shiftL` i + +delVar :: Int -> FreeVars -> FreeVars +delVar 0 (FreeVars i) = FreeVars $ i `shiftR` 1 +delVar 1 (FreeVars i) = FreeVars $ if testBit i 0 then (i `shiftR` 1) `setBit` 0 else (i `shiftR` 1) `clearBit` 0 +delVar l (FreeVars i) = FreeVars $ case i `shiftR` (l+1) of + 0 -> i `clearBit` l + x -> (x `shiftL` l) .|. (i .&. ((1 `shiftL` l)-1)) + +shiftFreeVars :: Int -> FreeVars -> FreeVars +shiftFreeVars i (FreeVars x) = FreeVars $ x `shift` i + +usedVar :: HasFreeVars a => Int -> a -> Bool +usedVar i (getFreeVars -> FreeVars a) = testBit a i + +freeVars :: FreeVars -> [Int] +freeVars (FreeVars x) = take (popCount x) [i | i <- [0..], testBit x i] + +isClosed :: FreeVars -> Bool +isClosed (FreeVars x) = x == 0 + +lowerFreeVars = shiftFreeVars (-1) + +rearrangeFreeVars g l (FreeVars i) = FreeVars $ case g of + RFUp n -> ((i `shiftR` l) `shiftL` (n+l)) .|. (i .&. ((1 `shiftL` l)-1)) + RFMove n -> (f $ (i `shiftR` l) `shiftL` (l+1)) .|. (i .&. ((1 `shiftL` l)-1)) + where + f x = if testBit x (n+l+1) then x `clearBit` (n+l+1) `setBit` l else x + _ -> error $ "rearrangeFreeVars: " ++ show g + + +-- TODO: rename +dbGE i x = dbGE_ i $ getFreeVars x + +dbGE_ i (FreeVars x) = (1 `shiftL` i) > x + +-------------------------------------------------------------------------------- type class for getting free variables + +class HasFreeVars a where + getFreeVars :: a -> FreeVars + +instance HasFreeVars FreeVars where + getFreeVars = id + +instance HasFreeVars Void where + getFreeVars = elimVoid + +-------------------------------------------------------------------------------- substitute names with De Bruijn indices + +class DeBruijnify n a where + deBruijnify_ :: Int -> [n] -> a -> a + +deBruijnify = deBruijnify_ 0 + +instance (DeBruijnify n a, DeBruijnify n b) => DeBruijnify n (a, b) where + deBruijnify_ k ns = deBruijnify_ k ns *** deBruijnify_ k ns + +instance (DeBruijnify n a, DeBruijnify n b) => DeBruijnify n (Either a b) where + deBruijnify_ k ns = deBruijnify_ k ns +++ deBruijnify_ k ns + +instance (DeBruijnify n a) => DeBruijnify n [a] where + deBruijnify_ k ns = fmap (deBruijnify_ k ns) + + diff --git a/src/LambdaCube/Compiler/DesugaredSource.hs b/src/LambdaCube/Compiler/DesugaredSource.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/DesugaredSource.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LambdaCube.Compiler.DesugaredSource + ( module LambdaCube.Compiler.DesugaredSource + , Fixity(..) + )where + +import Data.Monoid +import Data.Maybe +import Data.List +import Data.Function +import Data.Bits +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty --hiding (braces, parens) + +-------------------------------------------------------------------------------- simple name + +type SName = String + +pattern Ticked :: SName -> SName +pattern Ticked s = '\'': s + +untick (Ticked s) = s +untick s = s + +switchTick :: SName -> SName +switchTick (Ticked n) = n +switchTick n = Ticked n + +pattern CaseName :: SName -> SName +pattern CaseName cs <- 'c':'a':'s':'e':cs where CaseName cs = "case" ++ cs + +pattern MatchName :: SName -> SName +pattern MatchName cs <- 'm':'a':'t':'c':'h':cs where MatchName cs = "match" ++ cs + +-------------------------------------------------------------------------------- file position + +-- source position without file name +newtype SPos = SPos_ Int + deriving (Eq, Ord) + +row :: SPos -> Int +row (SPos_ i) = i `shiftR` 16 + +column :: SPos -> Int +column (SPos_ i) = i .&. 0xffff + +pattern SPos :: Int -> Int -> SPos +pattern SPos a b <- ((row &&& column) -> (a, b)) + where SPos a b = SPos_ $ (a `shiftL` 16) .|. b + +instance PShow SPos where + pShow (SPos r c) = pShow r <> ":" <> pShow c + +-------------------------------------------------------------------------------- file info + +data FileInfo = FileInfo + { fileId :: !Int + , filePath :: FilePath + , fileModule :: String -- module name + , fileContent :: String + } + +instance Eq FileInfo where (==) = (==) `on` fileId +instance Ord FileInfo where compare = compare `on` fileId + +instance PShow FileInfo where pShow = text . filePath --(++ ".lc") . fileModule + +showPos :: FileInfo -> SPos -> Doc +showPos n p = pShow n <> ":" <> pShow p + +-------------------------------------------------------------------------------- range + +data Range = Range + { rangeFile :: !FileInfo + , rangeStart :: !SPos + , rangeStop :: !SPos + } + deriving (Eq, Ord) + +instance Show Range where show = ppShow +instance PShow Range + where + pShow (Range n b@(SPos r c) e@(SPos r' c')) = expand (pShow n <+> pShow b <> "-" <> pShow e) + $ vcat $ (showPos n b <> ":") + : map text (drop (r - 1) $ take r' $ lines $ fileContent n) + ++ [text $ replicate (c - 1) ' ' ++ replicate (c' - c) '^' | r' == r] + +showRangeWithoutFileName (Range _ b e) = pShow b <> "-" <> pShow e + +joinRange :: Range -> Range -> Range +joinRange (Range n b e) (Range n' b' e') {- | n == n' -} = Range n (min b b') (max e e') + +-------------------------------------------------------------------------------- source info + +data SI + = NoSI (Set.Set String) -- no source info, attached debug info + | RangeSI Range + +getRange (RangeSI r) = Just r +getRange _ = Nothing + +--instance Show SI where show _ = "SI" +instance Eq SI where _ == _ = True +instance Ord SI where _ `compare` _ = EQ + +instance Monoid SI where + mempty = NoSI Set.empty + mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2) + mappend (NoSI ds1) (NoSI ds2) = NoSI (ds1 `Set.union` ds2) + mappend r@RangeSI{} _ = r + mappend _ r@RangeSI{} = r + +instance PShow SI where + pShow (NoSI ds) = hsep $ map text $ Set.toList ds + pShow (RangeSI r) = pShow r + +hashPos :: FileInfo -> SPos -> Int +hashPos fn (SPos_ p) = (1 + fileId fn) `shiftL` 32 .|. p + +debugSI a = NoSI (Set.singleton a) + +si@(RangeSI r) `validate` xs | r `notElem` [r | RangeSI r <- xs] = si +_ `validate` _ = mempty + +-------------------------------------------------------------------------------- type classes for source info + +class SourceInfo a where + sourceInfo :: a -> SI + +instance SourceInfo SI where + sourceInfo = id + +instance SourceInfo si => SourceInfo [si] where + sourceInfo = foldMap sourceInfo + +class SetSourceInfo a where + setSI :: SI -> a -> a + +-------------------------------------------------------------------------------- name with source info + +data SIName = SIName__ { nameHash :: Int, nameSI :: SI, nameFixity :: Maybe Fixity, sName :: SName } + +pattern SIName_ si f n <- SIName__ _ si f n + where SIName_ si f n = SIName__ (fnameHash si n) si f n + +pattern SIName si n <- SIName_ si _ n + where SIName si n = SIName_ si Nothing n + +instance Eq SIName where (==) = (==) `on` sName +instance Ord SIName where compare = compare `on` sName +instance Show SIName where show = sName +instance PShow SIName + where + pShow (SIName_ si f n) = expand (if isOpName n then DOp0 n (defaultFixity f) else maybe (text n) (DOp0 n) f) $ case si of + NoSI{} -> text n --maybe (text n) (DOp0 n) f + _ -> pShow si + +instance SourceInfo SIName where + sourceInfo (SIName si _) = si + +instance SetSourceInfo SIName where + setSI si (SIName_ _ f s) = SIName_ si f s + +-------------------------------------------------------------------------------- hashed names + +newtype FName = FName { fName :: SIName } + +instance Eq FName where (==) = (==) `on` nameHash . fName +instance Ord FName where compare = compare `on` nameHash . fName +instance Show FName where show = show . fName +instance PShow FName where pShow = pShow . fName + +data FNameTag + -- type constructors & constructors + = F'Type + | F'Empty + | F'Unit | FTT + | F'Constraint | FCUnit | FCEmpty + | F'Nat | FZero | FSucc + | F'Bool | FFalse | FTrue + | F'Ordering | FLT | FGT | FEQ + | F'List | FNil | FCons + | F'HList | FHCons | FHNil + | F'VecS | FV2 | FV3 | FV4 + | FRecordCons + | FRecItem + | FSx | FSy | FSz | FSw + | F'Int + | F'Word + | F'Float + | F'String + | F'Char + | F'Output + -- type functions + | F'T2 | F'EqCT | F'CW | F'Split | F'VecScalar + -- functions + | Fcoe | FparEval | Ft2C | FprimFix + | Fparens | FtypeAnn | Fundefined | Fotherwise | FprimIfThenElse | FfromTo | FconcatMap | FfromInt | Fproject | Fswizzscalar | Fswizzvector + + | FunsafeCoerce | FreflCstr | FhlistNilCase | FhlistConsCase + | FprimAddInt | FprimSubInt | FprimModInt | FprimSqrtFloat | FprimRound | FprimIntToFloat | FprimIntToNat | FprimCompareInt | FprimCompareFloat | FprimCompareChar | FprimCompareString + | FPrimGreaterThan | FPrimGreaterThanEqual | FPrimLessThan | FPrimLessThanEqual | FPrimEqualV | FPrimNotEqualV | FPrimEqual | FPrimNotEqual | FPrimSubS | FPrimSub | FPrimAddS | FPrimAdd | FPrimMulS | FPrimMul | FPrimDivS | FPrimDiv | FPrimModS | FPrimMod | FPrimNeg | FPrimAnd | FPrimOr | FPrimXor | FPrimNot + + -- other + | F_rhs | F_section + deriving (Eq, Ord, Show, Enum, Bounded) + +tagName FCons = ":" +tagName t = case show t of 'F': s -> s + +pattern Tag :: FNameTag -> SIName +pattern Tag t <- (toTag . nameHash -> Just t) + where Tag t = SIName__ (fromEnum t) (tagSI t) (tagFixity t) (tagName t) + +pattern FTag t = FName (Tag t) + +toTag i + | i <= fromEnum (maxBound :: FNameTag) = Just (toEnum i) + | otherwise = Nothing + +tagFixity FCons = Just $ InfixR 5 +tagFixity _ = Nothing + +tagSI t = NoSI $ Set.singleton $ tagName t + +fnameHash :: SI -> SName -> Int +fnameHash (RangeSI (Range fn p _)) s = maybe (hashPos fn p) fromEnum $ Map.lookup s fntable +fnameHash _ s = 0xffff -- TODO error $ "mkFName: " ++ show s + +fntable :: Map.Map String FNameTag +fntable = Map.fromList $ (tagName &&& id) <$> [minBound ..] + +-------------------------------------------------------------------------------- literal + +data Lit + = LInt Integer + | LChar Char + | LFloat Double + | LString String + deriving (Eq) + +instance PShow Lit where + pShow = \case + LFloat x -> pShow x + LString x -> text $ show x + LInt x -> pShow x + LChar x -> pShow x + +-------------------------------------------------------------------------------- expression + +data SExp' a + = SLit SI Lit + | SGlobal SIName + | SApp_ SI Visibility (SExp' a) (SExp' a) + | SBind_ SI Binder (SData SIName){-parameter name-} (SExp' a) (SExp' a) + | SVar_ (SData SIName) !Int + | SLet_ SI (SData SIName) (SExp' a) (SExp' a) -- let x = e in f --> SLet e f{-x is Var 0-} + | SLHS SIName (SExp' a) + | STyped a + deriving (Eq) + +sLHS _ (SRHS x) = x +sLHS n x = SLHS n x + +type SExp = SExp' Void + +data Binder + = BPi Visibility + | BLam Visibility + | BMeta -- a metavariable is like a floating hidden lambda + deriving (Eq) + +instance PShow Binder where + pShow = \case + BPi v -> "BPi" `DApp` pShow v + BLam v -> "BLam" `DApp` pShow v + BMeta -> "BMeta" + +data Visibility = Hidden | Visible + deriving (Eq) + +instance PShow Visibility where + pShow = \case + Hidden -> "Hidden" + Visible -> "Visible" + +dummyName s = SIName (debugSI s) "" --("v_" ++ s) +dummyName' = SData . dummyName +sVar = SVar . dummyName + +pattern SBind v x a b <- SBind_ _ v x a b + where SBind v x a b = SBind_ (sourceInfo a <> sourceInfo b) v x a b +pattern SPi h a b <- SBind (BPi h) _ a b + where SPi h a b = SBind (BPi h) (dummyName' "SPi") a b +pattern SLam h a b <- SBind (BLam h) _ a b + where SLam h a b = SBind (BLam h) (dummyName' "SLam") a b +pattern Wildcard t <- SBind BMeta _ t (SVar _ 0) + where Wildcard t = SBind BMeta (dummyName' "Wildcard") t (sVar "Wildcard2" 0) +pattern SLet n a b <- SLet_ _ (SData n) a b + where SLet n a b = SLet_ (sourceInfo a <> sourceInfo b) (SData n) a b +pattern SLamV a = SLam Visible (Wildcard SType) a +pattern SVar a b = SVar_ (SData a) b + +pattern SApp h a b <- SApp_ _ h a b + where SApp h a b = SApp_ (sourceInfo a <> sourceInfo b) h a b +pattern SAppH a b = SApp Hidden a b +pattern SAppV a b = SApp Visible a b +pattern SAppV2 f a b = f `SAppV` a `SAppV` b + +infixl 2 `SAppV`, `SAppH` + +pattern SBuiltin s = SGlobal (Tag s) + +pattern SRHS a = SBuiltin F_rhs `SAppV` a +pattern Section e = SBuiltin F_section `SAppV` e +pattern SType = SBuiltin F'Type +pattern SConstraint = SBuiltin F'Constraint +pattern Parens e = SBuiltin Fparens `SAppV` e +pattern SAnn a t = SBuiltin FtypeAnn `SAppH` t `SAppV` a +pattern TyType a = SAnn a SType +pattern SCW a = SBuiltin F'CW `SAppV` a + +-- builtin heterogenous list +pattern HList a = SBuiltin F'HList `SAppV` a +pattern HCons a b = SBuiltin FHCons `SAppV` a `SAppV` b +pattern HNil = SBuiltin FHNil + +-- builtin list +pattern BList a = SBuiltin F'List `SAppV` a +pattern BCons a b = SBuiltin FCons `SAppV` a `SAppV` b +pattern BNil = SBuiltin FNil + +getTTuple (HList (getList -> Just xs)) = xs +getTTuple x = [x] + +getList BNil = Just [] +getList (BCons x (getList -> Just y)) = Just (x:y) +getList _ = Nothing + +sLit = SLit mempty + +isPi (BPi _) = True +isPi _ = False + +pattern UncurryS :: [(Visibility, SExp' a)] -> SExp' a -> SExp' a +pattern UncurryS ps t <- (getParamsS -> (ps, t)) + where UncurryS ps t = foldr (uncurry SPi) t ps + +getParamsS (SPi h t x) = first ((h, t):) $ getParamsS x +getParamsS x = ([], x) + +pattern AppsS :: SExp' a -> [(Visibility, SExp' a)] -> SExp' a +pattern AppsS f args <- (getApps -> (f, args)) + where AppsS = foldl $ \a (v, b) -> SApp v a b + +getApps = second reverse . run where + run (SApp h a b) = second ((h, b):) $ run a + run x = (x, []) + +-- todo: remove +downToS err n m = [sVar (err ++ "_" ++ show i) (n + i) | i <- [m-1, m-2..0]] + +instance SourceInfo (SExp' a) where + sourceInfo = \case + SGlobal sn -> sourceInfo sn + SBind_ si _ _ _ _ -> si + SApp_ si _ _ _ -> si + SLet_ si _ _ _ -> si + SVar sn _ -> sourceInfo sn + SLit si _ -> si + SLHS n x -> sourceInfo x + STyped _ -> mempty + +instance SetSourceInfo SExp where + setSI si = \case + SBind_ _ a b c d -> SBind_ si a b c d + SApp_ _ a b c -> SApp_ si a b c + SLet_ _ le a b -> SLet_ si le a b + SVar sn i -> SVar (setSI si sn) i + SGlobal sn -> SGlobal (setSI si sn) + SLit _ l -> SLit si l + SLHS n x -> SLHS n $ setSI si x + STyped v -> elimVoid v + +foldS + :: Monoid m + => (Int -> t -> m) + -> (SIName -> Int -> m) + -> (SIName -> Int -> Int -> m) + -> Int + -> SExp' t + -> m +foldS h g f = fs + where + fs i = \case + SApp _ a b -> fs i a <> fs i b + SLet _ a b -> fs i a <> fs (i+1) b + SBind_ _ _ _ a b -> fs i a <> fs (i+1) b + SVar sn j -> f sn j i + SGlobal sn -> g sn i + x@SLit{} -> mempty + SLHS _ x -> fs i x + STyped x -> h i x + +foldName f = foldS (\_ -> elimVoid) (\sn _ -> f sn) mempty 0 + +usedS :: SIName -> SExp -> Bool +usedS n = getAny . foldName (Any . (== n)) + +mapS + :: (Int -> a -> SExp' a) + -> (SIName -> Int -> SExp' a) + -> (SIName -> Int -> Int{-level-} -> SExp' a) + -> Int + -> SExp' a + -> SExp' a +mapS hh gg f2 = g where + g i = \case + SApp_ si v a b -> SApp_ si v (g i a) (g i b) + SLet_ si x a b -> SLet_ si x (g i a) (g (i+1) b) + SBind_ si k si' a b -> SBind_ si k si' (g i a) (g (i+1) b) + SVar sn j -> f2 sn j i + SGlobal sn -> gg sn i + SLHS n x -> SLHS n $ g i x + STyped x -> hh i x + x@SLit{} -> x + +instance HasFreeVars a => HasFreeVars (SExp' a) where + getFreeVars = foldS (\l x -> shiftFreeVars (-l) $ getFreeVars x) mempty (\sn i l -> if i >= l then freeVar $ i - l else mempty) 0 + +instance Rearrange a => Rearrange (SExp' a) where + rearrange i f = mapS (\i x -> STyped $ rearrange i f x) (const . SGlobal) (\sn j i -> SVar sn $ if j < i then j else i + rearrangeFun f (j - i)) i + +instance DeBruijnify SIName SExp where + deBruijnify_ j xs + = mapS (\_ -> elimVoid) (\sn x -> maybe (SGlobal sn) (\i -> SVar sn $ i + x) $ elemIndex sn xs) + (\sn j k -> SVar sn $ if j >= k then j + l else j) j + where + l = length xs + +trSExp :: (a -> b) -> SExp' a -> SExp' b +trSExp f = g where + g = \case + SApp_ si v a b -> SApp_ si v (g a) (g b) + SLet_ si x a b -> SLet_ si x (g a) (g b) + SBind_ si k si' a b -> SBind_ si k si' (g a) (g b) + SVar sn j -> SVar sn j + SGlobal sn -> SGlobal sn + SLit si l -> SLit si l + SLHS n x -> SLHS n (g x) + STyped a -> STyped $ f a + +trSExp' :: SExp -> SExp' a +trSExp' = trSExp elimVoid + +instance (HasFreeVars a, PShow a) => PShow (SExp' a) where + pShow = \case + SGlobal ns -> pShow ns + Parens x -> pShow x -- TODO: remove + SAnn a b -> shAnn (pShow a) (pShow b) + TyType a -> text "tyType" `DApp` pShow a + SApp h a b -> shApp h (pShow a) (pShow b) + Wildcard SType -> text "_" + Wildcard t -> shAnn (text "_") (pShow t) + SBind_ _ h (SData n) SType b -> shLam_ (usedVar' 0 b $ sName n) h Nothing (pShow b) + SBind_ _ h (SData n) a b -> shLam (usedVar' 0 b $ sName n) h (pShow a) (pShow b) + SLet _ a b -> shLet_ (pShow a) (pShow b) + SLHS n x -> "_lhs" `DApp` pShow n `DApp` pShow x + STyped a -> pShow a + SVar _ i -> shVar i + SLit _ l -> pShow l + +shApp Visible a b = DApp a b +shApp Hidden a b = DApp a (DAt b) + +usedVar' a b s | usedVar a b = Just s + | otherwise = Nothing + +shLam usedVar h a b = shLam_ usedVar h (Just a) b + +simpleFo (DExpand x _) = x +simpleFo x = x + +shLam_ Nothing (BPi Hidden) (Just ((simpleFo -> DText "'CW") `DApp` a)) b = DFreshName Nothing $ showContext (DUp 0 a) b + where + showContext x (DFreshName u d) = DFreshName u $ showContext (DUp 0 x) d + showContext x (DParContext xs y) = DParContext (DComma x xs) y + showContext x (DContext xs y) = DParContext (DComma x xs) y + showContext x y = DContext x y + +shLam_ usedVar h a b = DFreshName usedVar $ lam (p $ DUp 0 <$> a) b + where + lam = case h of + BPi Visible + | isJust usedVar -> showForall "->" + | otherwise -> shArr + BPi Hidden + | isJust usedVar -> showForall "." + | otherwise -> showContext + _ -> showLam + + shAnn' a = maybe a (shAnn a) + + p = case h of + BMeta -> shAnn' (blue $ DVar 0) + BLam Hidden -> DAt . shAnn' (DVar 0) + BLam Visible -> shAnn' (DVar 0) + _ -> ann + + ann | isJust usedVar = shAnn' (DVar 0) + | otherwise = fromMaybe (text "Type") + + showForall s x (DFreshName u d) = DFreshName u $ showForall s (DUp 0 x) d + showForall s x (DForall s' xs y) | s == s' = DForall s (DSep (InfixR 11) x xs) y + showForall s x y = DForall s x y + + showContext x y = DContext' x y + +showLam x (DFreshName u d) = DFreshName u $ showLam (DUp 0 x) d +showLam x (DLam xs y) = DLam (DSep (InfixR 11) x xs) y +showLam x y = DLam x y + +shLet i a b = DLet' (DLet "=" (blue $ shVar i) $ DUp i a) (DUp i b) + +showLet x (DFreshName u d) = DFreshName u $ showLet (DUp 0 x) d +showLet x (DLet' xs y) = DLet' (DSemi x xs) y +showLet x y = DLet' x y + +shLet_ a b = DFreshName (Just "") $ showLet (DLet "=" (shVar 0) $ DUp 0 a) b + +-------------------------------------------------------------------------------- statement + +data Stmt + = StmtLet SIName SExp + | Data SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} [(SIName, SExp)]{-constructor names and types-} + | PrecDef SIName Fixity + +pattern StLet n mt x <- StmtLet n (getSAnn -> (x, mt)) + where StLet n mt x = StmtLet n $ maybe x (SAnn x) mt + +getSAnn (SAnn x t) = (x, Just t) +getSAnn x = (x, Nothing) + +pattern Primitive n t = StLet n (Just t) (SBuiltin Fundefined) + +instance PShow Stmt where + pShow stmt = vcat . map DResetFreshNames $ case stmt of + Primitive n t -> pure $ shAnn (pShow n) (pShow t) + StLet n ty e -> [shAnn (pShow n) (pShow t) | Just t <- [ty]] ++ [DLet "=" (pShow n) (pShow e)] + Data n ps ty cs -> pure $ nest 2 $ "data" <+> nest 2 (shAnn (foldl DApp (DTypeNamespace True $ pShow n) [shAnn (text "_") (pShow t) | (v, t) <- ps]) (pShow ty)) "where" <> nest 2 (hardline <> vcat [shAnn (pShow n) $ pShow $ UncurryS (first (const Hidden) <$> ps) t | (n, t) <- cs]) + PrecDef n i -> pure $ pShow i <+> text (sName n) --DOp0 (sName n) i + +instance DeBruijnify SIName Stmt where + deBruijnify_ k v = \case + StmtLet sn e -> StmtLet sn (deBruijnify_ k v e) + x@PrecDef{} -> x + x -> error $ "deBruijnify @ " ++ ppShow x + +-------------------------------------------------------------------------------- module + +data Module_ a = Module + { extensions :: Extensions + , moduleImports :: [(SIName, ImportItems)] + , moduleExports :: Maybe [Export] + , definitions :: a + } + +data Export = ExportModule SIName | ExportId SIName + +data ImportItems + = ImportAllBut [SIName] + | ImportJust [SIName] + +type Extensions = [Extension] + +data Extension + = NoImplicitPrelude + | TraceTypeCheck + deriving (Enum, Eq, Ord, Show) + +extensionMap :: Map.Map String Extension +extensionMap = Map.fromList $ map (show &&& id) [toEnum 0 .. ] + 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 @@ -1,1523 +1,585 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- TODO: remove -{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove --- {-# OPTIONS_GHC -O0 #-} -module LambdaCube.Compiler.Infer - ( 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) +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- TODO: remove +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove +-- {-# OPTIONS_GHC -O0 #-} +module LambdaCube.Compiler.Infer + ( inference + , neutType' + , makeCaseFunPars' + ) where + +import Data.Function +import Data.Monoid +import Data.Maybe +import Data.List +import qualified Data.Set as Set + +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (braces, parens) +import LambdaCube.Compiler.DesugaredSource hiding (getList) +import LambdaCube.Compiler.Core +import LambdaCube.Compiler.InferMonad + +------------------------------------------------------------------------------------ + +varType :: String -> Int -> Env -> (Binder, Exp) +varType err n_ env = f n_ env where + f n (EAssign i (ET 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 _ (ET 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 + +mkELet n x xt env = mkFun fn (Var <$> reverse vs) x + where + fn = FunName (FName n) (length vs) (ExpDef $ foldr addLam x vs) (foldr addPi xt vs) + + addLam v x = Lam $ rMove v 0 x + addPi v x = Pi Visible (snd $ varType "mkELet" v env) $ rMove v 0 x + + vs = nub . concat $ grow [] mempty $ free x <> free xt + + -- TODO: avoid infinite loop if variable types refer each-other mutually + grow accu acc s + | Set.null s = accu + | otherwise = grow (Set.toList s: accu) acc' s' + where + acc' = s <> acc + s' = mconcat (free . snd . flip (varType "mkELet2") env <$> Set.toList s) + +instance MkDoc a => PShow (CEnv a) where + pShow = mkDoc (False, False) + +instance PShow Env where + pShow e = envDoc e $ underline $ text "<>" + +showEnvExp :: Env -> ExpType -> String +showEnvExp e c = show $ envDoc e $ underline $ pShow c + +showEnvSExp :: (PShow a, HasFreeVars a) => Env -> SExp' a -> String +showEnvSExp e c = show $ envDoc e $ underline $ pShow c + +showEnvSExpType :: (PShow a, HasFreeVars a) => Env -> SExp' a -> Exp -> String +showEnvSExpType e c t = show $ envDoc e $ underline $ (shAnn (pShow c) (pShow t)) + +envDoc :: Env -> Doc -> Doc +envDoc x m = case x of + EGlobal{} -> m + EBind1 _ h ts b -> envDoc ts $ shLam (usedVar' 0 b "") h m (pShow b) + EBind2 h a ts -> envDoc ts $ shLam (Just "") h (pShow a) m + EApp1 _ h ts b -> envDoc ts $ shApp h m (pShow b) + EApp2 _ h (ET (Lam (Var 0)) (Pi Visible TType _)) ts -> envDoc ts $ shApp h (text "tyType") m + EApp2 _ h a ts -> envDoc ts $ shApp h (pShow a) m + ELet1 _ ts b -> envDoc ts $ shLet_ m (pShow b) + ELet2 _ x ts -> envDoc ts $ shLet_ (pShow x) m + EAssign i x ts -> envDoc ts $ shLet i (pShow x) m + CheckType t ts -> envDoc ts $ shAnn m $ pShow t + CheckIType t ts -> envDoc ts $ shAnn m (text "??") -- 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 + ERHS ts -> envDoc ts $ shApp Visible "rhs" m + ELHS n ts -> envDoc ts $ shApp Visible ("lhs" `DApp` pShow n) m + x -> error $ "envDoc: " ++ ppShow x + +instance MkDoc a => MkDoc (CEnv a) where + mkDoc pr = \case + MEnd a -> mkDoc pr a + Meta a b -> shLam (Just "") BMeta (mkDoc pr a) (mkDoc pr b) + Assign i (ET x _) e -> shLet i (mkDoc pr x) (mkDoc pr e) + +-------------------------------------------------------------------------------- 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 (Functor) + +instance (Subst Exp a, Rearrange a) => Rearrange (CEnv a) where + rearrange l f = \case + MEnd a -> MEnd $ rearrange l f a + Meta a b -> Meta (rearrange l f a) (rearrange (l+1) f b) + Assign j a b + | l > j -> assign j (rearrange (l-1) f a) (rearrange (l-1) f b) + | l <= j -> assign (rearrangeFun f (j-l) + l) (rearrange l f a) (rearrange l f b) + +instance (Subst Exp a, Rearrange 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) (shiftFreeVars 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) (expr 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 (expr 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_ (ty a) x $ expr a) $ up1_ 0 b + +--swapAssign :: (Int -> Exp -> CEnv Exp -> a) -> (Int -> Exp -> CEnv Exp -> a) -> Int -> Exp -> CEnv Exp -> a +swapAssign _ clet i (ET (Var j) t) b | i > j = clet j (ET (Var (i-1)) t) $ subst j (Var (i-1)) $ up1_ i b +swapAssign clet _ i a b = clet i a b + +--assign :: Rearrange a => Int -> ExpType -> CEnv a -> CEnv a +assign = swapAssign Assign Assign + +replaceMetas bind = \case + Meta a t -> bind a $ replaceMetas bind t + Assign i x t | x' <- up1_ i x -> bind (cstr_ (ty x') (Var i) $ expr x') . up 1 . up1_ i $ replaceMetas bind t + MEnd t -> t + + +-------------------------------------------------------------------------------- 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 + | ERHS Env + | ELHS SIName 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 + +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 + ERHS x -> Right x + ELHS _ x -> Right x + EGlobal -> Left () + +-------------------------------------------------------------------------------- simple typing + +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 + +makeCaseFunPars te n = case neutType te n of + (hnf -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) -> take pars $ reverse xs + x -> error $ "makeCaseFunPars: " ++ ppShow x + +makeCaseFunPars' te n = case neutType' te n of + (hnf -> TyCon (TyConName _ _ _ _ (CaseFunName _ _ pars)) xs) -> take pars $ reverse xs + +-------------------------------------------------------------------------------- inference + +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) + +mkLet x xt y = subst 0 x y +--mkLet x xt (ET y yt) = ET (Let (ET x xt) y) yt + +ET a at `etApp` e = ET (app_ a e) (appTy at e) + +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) $ case exp of + Parens x -> infer te x + SAnn x t -> checkN (CheckIType x te) t TType + SRHS x -> infer (ERHS te) x + SLHS n x -> infer (ELHS n te) x + SVar sn i -> focusTell te exp $ ET (Var i) $ snd $ varType "C2" i te + SLit si l -> focusTell te exp $ ET (ELit l) (nType l) + STyped et -> focusTell' te exp et + SGlobal (SIName si s) -> focusTell te exp =<< getDef te si s + SLet le a b -> infer (ELet1 le te b{-in-}) a{-let-} -- infer te SLamV b `SAppV` a) + SApp_ si h a b -> infer (EApp1 (si `validate` [sourceInfo a, sourceInfo b]) h te b) 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{-hnf-} -> 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 + | SBuiltin FprimFix `SAppV` (SLam Visible _ f) <- e = do + pf <- getDef te mempty "primFix" + checkN (EBind2 (BLam Visible) t $ EApp2 mempty Visible (pf `etApp` t) te) f $ up 1 t + | x@(SGlobal (sName -> MatchName n)) `SAppV` SLamV (Wildcard _) `SAppV` a `SAppV` SVar siv v `SAppV` b <- e + = infer te $ x `SAppV` SLam Visible SType (STyped (ET (subst (v+1) (Var 0) $ up 1 t) TType)) `SAppV` a `SAppV` SVar siv v `SAppV` b + -- temporal hack + | x@(SGlobal (sName -> CaseName "'Nat")) `SAppV` SLamV (Wildcard _) `SAppV` a `SAppV` b `SAppV` SVar siv v <- e + = infer te $ x `SAppV` SLamV (STyped (ET (substTo (v+1) (Var 0) $ up 1 t) TType)) `SAppV` a `SAppV` b `SAppV` SVar siv v + -- temporal hack + | x@(SGlobal (sName -> CaseName "'VecS")) `SAppV` SLamV (SLamV (Wildcard _)) `SAppV` a `SAppV` b `SAppV` c `SAppV` SVar siv v <- e + , TyConN (FTag F'VecS) [Var n', _] <- snd $ varType "xx" v te + = infer te $ x `SAppV` SLamV (SLamV (STyped (ET (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 (subst (n'+2) (Var 1) $ up1_ (n'+3) $ up 2 t, TType))) `SAppV` a `SAppV` b `SAppV` SVar siv v +-} + | SRHS x <- e = checkN (ERHS te) x t +{- TODO + | SAnn v a <- e = do + let x = t + let same = checkSame te a x + if same then checkN te v x else error $ "checkSame:\n" ++ ppShow a ++ "\nwith\n" ++ showEnvExp te (ET x TType) +-} + | SLHS n x <- e = checkN (ELHS n 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 $ hnf y else error $ "checkSame:\n" ++ ppShow a ++ "\nwith\n" ++ showEnvExp te (ET x TType) + | Pi Hidden a b <- t = do + bb <- notHiddenLam e + if bb then checkN (EBind2 (BLam Hidden) a te) (up1 e) $ hnf 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 (sName -> s) -> do + nv <- asks snd + case fromMaybe (error $ "infer: can't find: " ++ s) $ lookupName s nv of + ET (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 SType TType = True + checkSame te (SBind_ _ BMeta _ SType (STyped (ET (Var 0) _))) a = True + checkSame te a b = error $ "checkSame: " ++ ppShow (a, b) + + hArgs (Pi Hidden _ b) = 1 + hArgs b + hArgs _ = 0 + + focusTell env si eet = tellType si (ty eet) >> focus_ env eet + focusTell' env si eet = focus_ env eet + + focus_ :: Env -> ExpType -> IM m ExpType' + focus_ env eet@(ET e et) = tellTrace "focus" (showEnvExp env eet) $ case env of + ERHS te -> focus_ te (ET (RHS $ hnf e) et) + ELHS n te -> focus_ te (ET (mkELet n e et te) 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 $ hnf 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 (ET (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 (ET x{-let-} xt) te -> focus_ te $ mkLet x{-let-} xt eet{-in-} + CheckIType x te -> checkN te x $ hnf 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 te -> focusTell te si $ a `etApp` 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 -> focusTell te si $ ET (Pi h a e) TType + _ -> focus2 env $ MEnd eet + + focus2 :: Env -> CEnv ExpType -> IM 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 + | ERHS te' <- te -> refocus (ERHS $ EBind2_ si BMeta tt_ te') eet + | ELHS n te' <- te -> refocus (ELHS n $ EBind2_ si BMeta tt_ te') eet + | Unit <- tt -> refocus te $ subst 0 TT eet + | Empty msg <- tt -> throwError' $ ETypeError (text msg) si + | CW (hnf -> T2 _ x y) <- tt, let te' = EBind2_ si BMeta (up 1 $ cw y) $ EBind2_ si BMeta (cw x) te + -> refocus te' $ subst 2 (t2C (Var 1) (Var 0)) $ up 2 eet + | CW (hnf -> CstrT t a b) <- tt, Just r <- cst (ET a t) b -> r + | CW (hnf -> CstrT t a b) <- tt, Just r <- cst (ET b t) a -> r + | CW _ <- tt, EBind2 h x te' <- te, Just x' <- down 0 tt, x == x' + -> refocus te $ subst 1 (Var 0) eet + | EBind2_ si' 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 te' <- te, Just b' <- down 0 tt + -> refocus (ELet2 le (up 1 x) $ 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 $ ty $ 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 = hnf 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) (expr $ up 1 y) eet + _ -> Nothing + + EAssign i b te -> case te of + ERHS te' -> refocus' (ERHS $ EAssign i b te') eet + ELHS n te' -> refocus' (ELHS n $ EAssign i b te') eet + EBind2_ si h x te' | i > 0, Just b' <- down 0 b + -> refocus' (EBind2_ si h (subst (i-1) (expr b') x) (EAssign (i-1) b' te')) eet + ELet2 le x te' | i > 0, Just b' <- down 0 b + -> refocus' (ELet2 le (subst (i-1) (expr b') x) (EAssign (i-1) b' te')) eet + ELet1 le te' x -> refocus' (ELet1 le (EAssign i b te') $ subst (i+1) (up 1 b) x) eet + EBind1 si h te' x -> refocus' (EBind1 si h (EAssign i b te') $ subst (i+1) (up 1 b) x) eet + CheckAppType si h t te' x -> refocus' (CheckAppType si h (subst i (expr b) t) (EAssign i b te') $ subst i b x) eet + EApp1 si h te' x -> refocus' (EApp1 si h (EAssign i b te') $ subst i b x) eet + EApp2 si h x te' -> refocus' (EApp2 si h (subst i (expr b) x) $ EAssign i b te') eet + CheckType_ si t te' -> refocus' (CheckType_ si (subst i (expr b) t) $ EAssign i b te') eet + EAssign j a te' | i < j + -> refocus' (EAssign (j-1) (subst i (expr 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) (expr b') x) <$> pull1 (i-1) b' te + EAssign j a te + | i < j -> EAssign (j-1) (subst i (expr b) a) <$> pull1 i (up1_ (j-1) b) te + | j <= i -> EAssign j (subst i (expr 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:" <+> pShow x + _ -> case env of + _ -> throwError' $ ErrorMsg $ "focus checkMetas:" <$$> pShow env <$$> "---" <$$> pShow 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 + +-------------------------------------------------------------------------------- re-checking + +type Message = String + +recheck :: Monad m => SIName -> Env -> ExpType -> m ExpType +recheck sn e = return . recheck' sn e + +-- todo: check type also +recheck' :: SIName -> Env -> ExpType -> ExpType +recheck' sn e (ET x xt) = ET (recheck_ "main" (checkEnv e) (ET x xt)) xt + where + err s = error $ "At " ++ ppShow sn ++ "\n" ++ s + + 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@(ET x xt) = ET (recheck_ msg te a) xt + checkType te e = recheck_ "check" te (ET e TType) + + recheck_ msg te = \case + ET (Var k) zt -> Var k -- todo: check var type + ET (Lam_ md b) (Pi h a bt) -> Lam_ md $ recheck_ "9" (EBind2 (BLam h) a te) (ET b bt) + ET (Pi_ md h a b) TType -> Pi_ md h (checkType te a) $ checkType (EBind2 (BPi h) a te) b + ET (ELit l) zt -> ELit l -- todo: check literal type + ET TType TType -> TType + ET (Neut (App__ md a b)) zt + | ET (Neut a') at <- recheck'' "app1" te $ ET (Neut a) (neutType te a) + -> checkApps "a" [] zt (Neut . App__ md a' . head) te at [b] + ET (Con_ md s n as) zt -> checkApps (ppShow s) [] zt (Con_ md s n . reverse . drop (conParams s)) te (conType zt s) $ mkConPars n zt ++ reverse as + ET (TyCon_ md s as) zt -> checkApps (ppShow s) [] zt (TyCon_ md s . reverse) te (nType s) $ reverse as + ET (Neut (CaseFun__ fs s@(CaseFunName _ t pars) as n)) zt -> checkApps (ppShow s) [] zt (\xs -> evalCaseFun fs s (init $ drop pars xs) (last xs)) te (nType s) (makeCaseFunPars te n ++ as ++ [Neut n]) + ET (Neut (TyCaseFun__ fs s [m, t, f] n)) zt -> checkApps (ppShow s) [] zt (\[m, t, n, f] -> evalTyCaseFun_ fs s [m, t, f] n) te (nType s) [m, t, Neut n, f] + ET (Neut (Fun_ md f a x)) zt -> checkApps ("lab-" ++ show f ++ ppShow a ++ "\n" ++ ppShow (nType f)) [] zt (\xs -> Neut $ Fun_ md f (reverse xs) x) te (nType f) $ reverse a -- TODO: recheck x + ET (Let (ET x xt) y) zt -> Let (recheck'' "let" te $ ET x xt) $ recheck_ "let_in" te $ ET y (Pi Visible xt $ up1 zt) -- TODO + ET (RHS x) zt -> RHS $ recheck_ msg te (ET x zt) + where + checkApps s acc zt f _ t [] + | t == zt = f $ reverse acc + | otherwise = + err $ "checkApps' " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp te (ET zt TType) + checkApps s acc zt f te t@(hnf -> Pi h x y) (b_: xs) = checkApps (s++"+") (b: acc) zt f te (appTy t b) xs where b = recheck_ "checkApps" te (ET b_ x) + checkApps s acc zt f te t _ = + err $ "checkApps " ++ s ++ " " ++ msg ++ "\n" ++ showEnvExp te{-todo-} (ET t TType) ++ "\n\n" ++ showEnvExp e (ET x xt) + +-------------------------------------------------------------------------------- inference for statements + +inference :: MonadFix m => [Stmt] -> IM m [GlobalEnv] +inference [] = return [] +inference (x:xs) = do + y <- handleStmt x + (y:) <$> withEnv y (inference xs) + +handleStmt :: MonadFix m => Stmt -> IM m GlobalEnv +handleStmt = \case + Primitive n t_ -> do + t <- inferType n $ trSExp' t_ + tellType (sourceInfo n) t + let fn = mkFunDef (FName n) t + addToEnv n $ flip ET t $ lamify' t $ \xs -> Neut $ Fun fn xs delta + StLet n mt t_ -> do + let t__ = maybe id (flip SAnn) mt t_ + ET x t <- inferTerm n $ trSExp' t__ + tellType (sourceInfo n) t + addToEnv n (ET x 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_@(UncurryS tl_ _)) cs -> do + vty <- inferType s $ UncurryS ps t_ + tellType (sourceInfo s) vty + let + sint = FName s + pnum' = length $ filter ((== Visible) . fst) ps + inum = arity vty - length ps + + mkConstr j (cn, trSExp' -> ct@(UncurryS ctl (AppsS c (map snd -> xs)))) + | c == SGlobal s && take pnum' xs == downToS "a3" (length ctl) pnum' + = do + cty <- removeHiddenUnit <$> inferType cn (UncurryS [(Hidden, x) | (Visible, x) <- ps] ct) +-- tellType (sourceInfo cn) cty + let pars = zipWith (\x -> second $ STyped . flip ET TType . rUp (1+j) x) [0..] $ drop (length ps) $ fst $ getParams cty + act = length . fst . getParams $ cty + acts = map fst . fst . getParams $ cty + conn = ConName (FName cn) j cty + e <- addToEnv cn $ ET (Con conn 0 []) cty + return (e, ((conn, cty) + , UncurryS pars + $ (foldl SAppV (sVar ".cs" $ j + length pars) $ drop pnum' xs ++ [AppsS (SGlobal cn) (zip acts $ downToS ("a4 " ++ sName cn ++ " " ++ show (length ps)) (j+1+length pars) (length ps) ++ downToS "a5" 0 (act- length ps))] + :: SExp2))) + | otherwise = throwError' $ ErrorMsg "illegal data definition (parameters are not uniform)" -- ++ show (c, cn, take pnum' xs, act) + + motive = UncurryS (replicate inum (Visible, Wildcard SType)) $ + SPi Visible (AppsS (SGlobal s) $ zip (map fst ps) (downToS "a6" inum $ length ps) ++ zip (map fst tl_) (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 (ET (TyCon tcn []) vty) + (unzip -> (mconcat -> es, cons)) <- withEnv e1 $ zipWithM mkConstr [0..] cs + ct <- withEnv (e1 <> es) $ inferType s + ( UncurryS + ( [(Hidden, x) | (_, x) <- ps] + ++ (Visible, motive) + : map ((,) Visible . snd) cons + ++ replicate inum (Hidden, Wildcard SType) + ++ [(Visible, AppsS (SGlobal s) $ zip (map fst ps) (downToS "a8" (inum + length cs + 1) $ length ps) ++ zip (map fst tl_) (downToS "a9" 0 inum))] + ) + $ foldl SAppV (sVar ".ct" $ length cs + inum + 1) $ downToS "a10" 1 inum ++ [sVar ".24" 0] + ) + return (e1, es, tcn, cfn, ct, cons) + + e2 <- addToEnv (SIName (sourceInfo s) $ CaseName (sName s)) $ ET (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 (SIName (sourceInfo s) $ MatchName (sName s)) $ ET (lamify t $ \[m, tr, n, f] -> evalTyCaseFun (TyCaseFunName sint t) [m, tr, f] n) t + return (e1 <> e2 <> e3 <> es) + + stmt -> error $ "handleStmt: " ++ ppShow stmt + +inferTerm :: Monad m => SIName -> SExp2 -> IM m ExpType +inferTerm sn t = recheck sn EGlobal . replaceMetas (lamPi Hidden) =<< inferN EGlobal t + +inferType :: Monad m => SIName -> SExp2 -> IM m Type +inferType sn t = fmap expr + $ recheck sn EGlobal . flip ET TType . replaceMetas (Pi Hidden) . fmap expr + =<< inferN (CheckType_ (sourceInfo sn) TType EGlobal) t + diff --git a/src/LambdaCube/Compiler/InferMonad.hs b/src/LambdaCube/Compiler/InferMonad.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/InferMonad.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- TODO: remove +{-# OPTIONS_GHC -fno-warn-unused-binds #-} -- TODO: remove +module LambdaCube.Compiler.InferMonad where + +import Data.Monoid +import Data.List +--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.Arrow hiding ((<+>)) + +--import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (braces, parens) +import LambdaCube.Compiler.DesugaredSource hiding (getList) +import LambdaCube.Compiler.Parser (ParseWarning (..)) +import LambdaCube.Compiler.Core + +-------------------------------------------------------------------------------- error messages + +data ErrorMsg + = ErrorMsg Doc + | ECantFind SName SI + | ETypeError Doc SI + | ERedefined SName SI SI + +errorRange_ = \case + ErrorMsg s -> [] + ECantFind s si -> [si] + ETypeError msg si -> [si] + ERedefined s si si' -> [si, si'] + +instance PShow ErrorMsg where + pShow = \case + ErrorMsg s -> s + ECantFind s si -> "can't find:" <+> text s <+> "in" <+> pShow si + ETypeError msg si -> "type error:" <+> msg <$$> "in" <+> pShow si + ERedefined s si si' -> "already defined" <+> text s <+> "at" <+> pShow si <$$> "and at" <+> pShow si' + + +-------------------------------------------------------------------------------- infos + +data Info + = Info Range Doc + | IType SIName Exp + | ITrace String String + | IError ErrorMsg + | ParseWarning ParseWarning + +instance PShow Info where + pShow = \case + Info r s -> nest 4 $ shortForm (pShow r) <$$> s + IType a b -> shAnn (pShow a) (pShow b) + ITrace i s -> text i <> ": " <+> text s + IError e -> "!" <> pShow e + ParseWarning w -> pShow w + +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 f m + = h "trace" (listTraceInfos m) ++ listAllInfos' f m + where + h x [] = [] + h x xs = ("------------" <+> x) : xs + +listAllInfos' f m + = h "tooltips" [ nest 4 $ shortForm $ showRangeWithoutFileName r <$$> hsep (intersperse "|" is) + | (r, is) <- listTypeInfos m, maybe False (rangeFile r ==) f ] + ++ h "warnings" [ pShow w | ParseWarning w <- m ] + where + h x [] = [] + h x xs = ("------------" <+> x) : xs + +listTraceInfos m = [DResetFreshNames $ pShow i | i <- m, case i of Info{} -> False; ParseWarning{} -> False; _ -> True] +listTypeInfos m = Map.toList $ Map.unionsWith (<>) [Map.singleton r [DResetFreshNames i] | Info r i <- m] +listErrors m = Map.toList $ Map.unionsWith (<>) [Map.singleton r [DResetFreshNames (pShow e)] | IError e <- m, RangeSI r <- errorRange_ e] +listWarnings m = Map.toList $ Map.unionsWith (<>) [Map.singleton r [DResetFreshNames msg] | ParseWarning (getRangeAndMsg -> Just (r, msg)) <- m] + where + getRangeAndMsg = \case + Unreachable r -> Just (r, "Unreachable") + w@(Uncovered (getRange . sourceInfo -> Just r) _) -> Just (r, pShow w) + _ -> Nothing + +tellType si t = tell $ mkInfoItem (sourceInfo si) $ DTypeNamespace True $ pShow t + +-------------------------------------------------------------------------------- global env + +type GlobalEnv = Map.Map SName (Exp, Type, SI) + +initEnv :: GlobalEnv +initEnv = Map.fromList + [ (,) "'Type" (TType, TType, debugSI "source-of-Type") + ] + +-- inference monad +type IM m = ExceptT ErrorMsg (ReaderT (Extensions, GlobalEnv) (WriterT Infos m)) + +expAndType s (e, t, si) = (ET e t) + +-- todo: do only if NoTypeNamespace extension is not on +lookupName s@(Ticked 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) + +addToEnv :: Monad m => SIName -> ExpType -> IM m GlobalEnv +addToEnv sn@(SIName si s) (ET x t) = do +-- maybe (pure ()) throwError_ $ ambiguityCheck s t -- TODO +-- b <- asks $ (TraceTypeCheck `elem`) . fst + tell [IType sn t] + v <- asks $ Map.lookup s . snd + case v of + Nothing -> return $ Map.singleton s (x, t, si) + Just (_, _, si') -> throwError' $ ERedefined s si si' + + +removeHiddenUnit (Pi Hidden (hnf -> 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 + +lamify' t x = addLams (fst $ getParams t) $ x $ downTo' 0 $ arity t + +arity :: Exp -> Int +arity = length . fst . getParams + +downTo n m = map Var [n+m-1, n+m-2..n] +downTo' n m = map Var [n, n+1..n+m-1] + +withEnv e = local $ second (<> e) + +lamPi h t (ET x y) = ET (Lam x) (Pi h t y) + +-- 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" ++ ppShow 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 + +-- TODO: remove +free = Set.fromList . freeVars . getFreeVars + +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 + (hnf -> CW (hnf -> CstrT _{-todo-} ty f)) -> freeVars ty <-> freeVars f + (hnf -> 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) + + 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 @@ -3,231 +3,233 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance NFData SourcePos -{-# OPTIONS -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} module LambdaCube.Compiler.Lexer ( module LambdaCube.Compiler.Lexer - , module Pr + , module ParseUtils ) where -import Data.Monoid -import Data.Maybe import Data.List +import Data.List.NonEmpty (fromList) import Data.Char import qualified Data.Set as Set -import qualified Data.Map as Map - import Control.Monad.Except import Control.Monad.RWS -import Control.Arrow hiding ((<+>)) import Control.Applicative -import Control.DeepSeq +import Control.Arrow -import Text.Megaparsec -import Text.Megaparsec as Pr hiding (try, label, Message) -import Text.Megaparsec.Lexer hiding (lexeme, symbol, space, negate, symbol', indentBlock) -import Text.Megaparsec.Pos +import Text.Megaparsec hiding (State, ParseError) +import qualified Text.Megaparsec as P +import Text.Megaparsec as ParseUtils hiding (try, Message, State, ParseError) +import Text.Megaparsec.Lexer hiding (lexeme, symbol, negate) -import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) +import LambdaCube.Compiler.Pretty hiding (parens) +import LambdaCube.Compiler.DesugaredSource --------------------------------------------------------------------------------- parser utils +-------------------------------------------------------------------------------- utils +-- try with error handling -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602 try_ s m = try m s -manyNM a b _ | b < a || b < 0 || a < 0 = mzero -manyNM 0 0 _ = pure [] -manyNM 0 n p = option [] $ (:) <$> p <*> manyNM 0 (n-1) p -manyNM k n p = (:) <$> p <*> manyNM (k-1) (n-1) p - --------------------------------------------------------------------------------- parser type - -type P = ParsecT String (RWS ((DesugarInfo, Namespace), (Int, Int){-indentation level-}) [PostponedCheck] SourcePos) - -type PostponedCheck = Maybe String - -type DesugarInfo = (FixityMap, ConsMap) +toSPos :: SourcePos -> SPos +toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p) -type ConsMap = Map.Map SName{-constructor name-} - (Either ((SName{-case eliminator name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-}) - Int{-arity-}) +getSPos = toSPos <$> getPosition -dsInfo :: P DesugarInfo -dsInfo = asks $ fst . fst +-------------------------------------------------------------------------------- literals -namespace :: P Namespace -namespace = asks $ snd . fst +parseLit :: forall r w . Parse r w Lit +parseLit = lexeme (LChar <$> charLiteral <|> LString <$> stringLiteral <|> natFloat) "literal" + where + charLiteral :: Parse r w Char + charLiteral = between (char '\'') + (char '\'' "end of character") + (char '\\' *> escapeCode <|> satisfy ((&&) <$> (> '\026') <*> (/= '\'')) "character") -runP_ r f p = (\(a, s, w) -> (a, w)) $ runRWS p (r, (0, 0)) (initialPos f) + stringLiteral :: Parse r w String + stringLiteral = between (char '"') + (char '"' "end of string") + (concat <$> many stringChar) + where + stringChar = char '\\' *> stringEscape <|> (:[]) <$> satisfy ((&&) <$> (> '\026') <*> (/= '"')) "string character" -runP r f p s = runP_ r f $ runParserT p f s + stringEscape = [] <$ some simpleSpace <* (char '\\' "end of string gap") + <|> [] <$ char '&' + <|> (:[]) <$> escapeCode -runP' r f p st = runP_ r f $ runParserT' p st + escapeCode :: Parse r w Char + escapeCode = choice (charEsc ++ charNum: (char '^' *> charControl): charAscii) "escape code" + where + charControl = toEnum . (+ (-64)) . fromEnum <$> satisfy ((&&) <$> (>= 'A') <*> (<= '_')) "control char" --------------------------------------------------------------------------------- literals + charNum = toEnum . fromInteger <$> (decimal <|> char 'o' *> octal <|> char 'x' *> hexadecimal) -data Lit - = LInt Integer - | LChar Char - | LFloat Double - | LString String - deriving (Eq) + charEsc = zipWith (<$) "\a\b\t\n\v\f\r\\\"\'" $ map char "abtnvfr\\\"\'" -instance Show Lit where - show = \case - LFloat x -> show x - LString x -> show x - LInt x -> show x - LChar x -> show x + charAscii = zipWith (<$) y $ try . string <$> words x + where + x = "NUL SOH STX ETX EOT ENQ ACK BEL BS HT LF VT FF CR SO SI DLE DC1 DC2 DC3 DC4 NAK SYN ETB CAN EM SUB ESC FS GS RS US SP DEL" + -- 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 127 + -- ^A ^B ^C ^D ^E ^F ^G ^H ^I ^J ^K ^L ^M ^N ^O ^P ^Q ^R ^S ^T ^U ^V ^W ^X ^Y ^Z ^[ ^\ ^] ^^ ^_ + -- \a \b \t \n \v \f \r ' ' + y = toEnum <$> ([0..32] ++ [127]) --------------------------------------------------------------------------------- names + natFloat :: Parse r w Lit + natFloat = char '0' *> zeroNumFloat <|> decimalFloat + where + zeroNumFloat = LInt <$> (oneOf "xX" *> hexadecimal <|> oneOf "oO" *> octal) + <|> decimalFloat + <|> fractFloat 0 + <|> return (LInt 0) -type SName = String + decimalFloat = decimal >>= \n -> option (LInt n) (fractFloat n) -pattern CaseName :: String -> String -pattern CaseName cs <- (getCaseName -> Just cs) where CaseName = caseName + fractFloat n = LFloat <$> try (fractExponent $ fromInteger n) -caseName (c:cs) = toLower c: cs ++ "Case" -getCaseName cs = case splitAt 4 $ reverse cs of - (reverse -> "Case", xs) -> Just $ reverse xs - _ -> Nothing + fractExponent n = (*) <$> ((n +) <$> fraction) <*> option 1 exponent' + <|> (n *) <$> exponent' -pattern MatchName cs <- (getMatchName -> Just cs) where MatchName = matchName + fraction = foldr op 0 <$ char '.' <*> some digitChar "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10 -matchName cs = "match" ++ cs -getMatchName ('m':'a':'t':'c':'h':cs) = Just cs -getMatchName _ = Nothing + exponent' = (10^^) <$ oneOf "eE" <*> ((negate <$ char '-' <|> id <$ char '+' <|> return id) <*> decimal) "exponent" +-------------------------------------------------------------------------------- parser type --------------------------------------------------------------------------------- source infos +data ParseEnv r = ParseEnv + { fileInfo :: FileInfo + , desugarInfo :: r + , namespace :: Namespace + , indentationLevel :: SPos + } -instance NFData SourcePos where - rnf x = x `seq` () +type ParseState r = (ParseEnv r, P.State String) -data Range = Range SourcePos SourcePos - deriving (Eq, Ord) +parseState :: FileInfo -> r -> ParseState r +parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") id $ runParser (getParserState :: Parsec Dec String (P.State String)) (filePath fi) (fileContent fi)) -instance NFData Range where - rnf (Range a b) = rnf a `seq` rnf b `seq` () +--type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String))) +type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec Dec String) -instance PShow Range where - pShowPrec _ (Range b e) | sourceName b == sourceName e = text (sourceName b) <+> f b <> "-" <> f e - where - f x = pShow (sourceLine x) <> ":" <> pShow (sourceColumn x) +newtype ParseError = ParseErr (P.ParseError (Token String) Dec) -joinRange :: Range -> Range -> Range -joinRange (Range b e) (Range b' e') = Range (min b b') (max e e') +instance Show ParseError where + show (ParseErr e) = parseErrorPretty e -data SI - = NoSI (Set.Set String) -- no source info, attached debug info - | RangeSI Range +runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w]) +runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos") -instance NFData SI where - rnf = \case - NoSI x -> rnf x - RangeSI r -> rnf r +getParseState :: Parse r w (ParseState r) +getParseState = (,) <$> ask <*> getParserState -instance Show SI where show _ = "SI" -instance Eq SI where _ == _ = True -instance Ord SI where _ `compare` _ = EQ +----------------------------------------------------------- indentation, white space, symbols -instance Monoid SI where - mempty = NoSI Set.empty - mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2) - mappend (NoSI ds1) (NoSI ds2) = NoSI (ds1 `Set.union` ds2) - mappend r@RangeSI{} _ = r - mappend _ r@RangeSI{} = r +getCheckedSPos = do + p <- getSPos + p' <- asks indentationLevel + when (p /= p' && column p <= column p') $ fail "wrong indentation" + return p -instance PShow SI where - pShowPrec _ (NoSI ds) = hsep $ map pShow $ Set.toList ds - pShowPrec _ (RangeSI r) = pShow r +identation allowempty p = (if allowempty then option [] else id) $ do + pos' <- getCheckedSPos + (if allowempty then many else some) $ do + pos <- getSPos + guard (column pos == column pos') + local (\e -> e {indentationLevel = pos}) p -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 +lexemeWithoutSpace p = do + p1 <- getCheckedSPos + x <- p + p2 <- getSPos + put p2 + fi <- asks fileInfo + return (RangeSI $ Range fi p1 p2, x) -showSourcePosSI (NoSI ds) = unwords $ Set.toList ds -showSourcePosSI (RangeSI (Range s _)) = show s +-- TODO?: eliminate; when eliminated, the SPos in parser state can be eliminated too +appRange :: Parse r w (SI -> a) -> Parse r w a +appRange p = (\fi p1 a p2 -> a $ RangeSI $ Range fi p1 p2) <$> asks fileInfo <*> getSPos <*> p <*> getLexemeEnd --- TODO: remove -validSI RangeSI{} = True -validSI _ = False +getLexemeEnd = get -debugSI a = NoSI (Set.singleton a) +noSpaceBefore p = try $ do + pos <- getLexemeEnd + x <- p + guard $ case sourceInfo x of + RangeSI (Range _ pos' _) -> pos == pos' + return x -si@(RangeSI r) `validate` xs | all validSI xs && r `notElem` [r | RangeSI r <- xs] = si -_ `validate` _ = mempty +lexeme_ p = lexemeWithoutSpace p <* whiteSpace -sourceNameSI (RangeSI (Range a _)) = sourceName a +lexeme :: Parse r w a -> Parse r w a +lexeme p = snd <$> lexeme_ p -sameSource r@RangeSI{} q@RangeSI{} = sourceNameSI r == sourceNameSI q -sameSource _ _ = True +lexemeName p = uncurry SIName <$> lexeme_ p -class SourceInfo si where - sourceInfo :: si -> SI +symbolWithoutSpace = lexemeWithoutSpace . string -instance SourceInfo SI where - sourceInfo = id +symbol name = symbolWithoutSpace name <* whiteSpace -instance SourceInfo si => SourceInfo [si] where - sourceInfo = foldMap sourceInfo +simpleSpace = skipSome (satisfy isSpace) -class SetSourceInfo a where - setSI :: SI -> a -> a +whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") + where + oneLineComment + = try (string "--" >> many (char '-') >> notFollowedBy opLetter) + >> skipMany (satisfy (/= '\n')) -appRange :: P (SI -> a) -> P a -appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> get + multiLineComment = try (string "{-") *> inCommentMulti + where + inCommentMulti + = () <$ try (string "-}") + <|> multiLineComment *> inCommentMulti + <|> skipSome (noneOf "{}-") *> inCommentMulti + <|> oneOf "{}-" *> inCommentMulti + "end of comment" -type SIName = (SI, SName) +parens = between (symbol "(") (symbol ")") +braces = between (symbol "{") (symbol "}") +brackets = between (symbol "[") (symbol "]") --- todo: eliminate -psn p = appRange $ flip (,) <$> p +commaSep p = sepBy p $ symbol "," +commaSep1 p = sepBy1 p $ symbol "," -------------------------------------------------------------------------------- namespace handling data Namespace = TypeNS | ExpNS - deriving (Eq, Show) - -tick = (\case TypeNS -> switchTick; _ -> id) + deriving (Eq) -tick' c = (`tick` c) <$> namespace +tick c = f <$> asks namespace + where + f = \case TypeNS -> switchTick c; _ -> c switchNamespace = \case ExpNS -> TypeNS; TypeNS -> ExpNS - -switchTick ('\'': n) = n -switchTick n = '\'': n -modifyLevel f = local $ first $ second f +modifyLevel f = local $ \e -> e {namespace = f $ namespace e} -typeNS, expNS, switchNS :: P a -> P a +typeNS, expNS :: Parse r w a -> Parse r w a typeNS = modifyLevel $ const TypeNS expNS = modifyLevel $ const ExpNS -switchNS = modifyLevel $ switchNamespace -------------------------------------------------------------------------------- identifiers -lowerLetter = satisfy $ \c -> isLower c || c == '_' -upperLetter = satisfy isUpper -identStart = satisfy $ \c -> isLetter c || c == '_' -identLetter = satisfy $ \c -> isAlphaNum c || c == '_' || c == '\'' || c == '#' +lowerLetter = satisfy $ (||) <$> isLower <*> (== '_') +upperLetter = satisfy isUpper +identStart = satisfy $ (||) <$> isLetter <*> (== '_') +identLetter = satisfy $ (||) <$> isAlphaNum <*> (`elem` ("_\'#" :: [Char])) lowercaseOpLetter = oneOf "!#$%&*+./<=>?@\\^|-~" opLetter = lowercaseOpLetter <|> char ':' maybeStartWith p i = i <|> (:) <$> satisfy p <*> i -upperCase = identifier (tick' =<< (:) <$> upperLetter <*> many identLetter) "uppercase ident" -upperCase_ = identifier (tick' =<< maybeStartWith (=='\'') ((:) <$> upperLetter <*> many identLetter)) "uppercase ident" +upperCase, upperCase_, lowerCase :: Parse r w SIName +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" @@ -235,76 +237,28 @@ colonSymbols = operator ((:) <$> satisfy (== ':') <*> many opLetter) "op symbols" moduleName = identifier (intercalate "." <$> sepBy1 ((:) <$> upperLetter <*> many identLetter) (char '.')) "module name" -patVar = second f <$> lowerCase where - f "_" = "" +patVar = f <$> lowerCase where + f (SIName si "_") = SIName si "" f x = x lhsOperator = lcSymbols <|> backquotedIdent rhsOperator = symbols <|> backquotedIdent varId = lowerCase <|> parens (symbols <|> backquotedIdent) upperLower = lowerCase <|> upperCase_ <|> parens symbols --------------------------------------------------------------------------------- fixity handling - -data FixityDef = Infix | InfixL | InfixR deriving (Show) -type Fixity = (FixityDef, Int) -type FixityMap = Map.Map SName Fixity - -calcPrec - :: (Show e, Show f) - => (f -> e -> e -> e) - -> (f -> Fixity) - -> e - -> [(f, e)] - -> e -calcPrec app getFixity e = compileOps [((Infix, -1000), error "calcPrec", e)] - where - compileOps [(_, _, e)] [] = e - compileOps acc [] = compileOps (shrink acc) [] - compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of - Right GT -> compileOps ((pr, op, e'): acc) es - Right LT -> compileOps (shrink acc) es_ - Left err -> error err - where - pr = getFixity op - - shrink ((_, op, e): (pr, op', e'): es) = (pr, op', app op e' e): es - - compareFixity ((dir, i), op) ((dir', i'), op') - | i > i' = Right GT - | i < i' = Right LT - | otherwise = case (dir, dir') of - (InfixL, InfixL) -> Right LT - (InfixR, InfixR) -> Right GT - _ -> Left $ "fixity error:" ++ show (op, op') - -parseFixityDecl :: P [(SIName, Fixity)] -parseFixityDecl = do - dir <- Infix <$ reserved "infix" - <|> InfixL <$ reserved "infixl" - <|> InfixR <$ reserved "infixr" - LInt n <- parseLit - let i = fromIntegral n - ns <- commaSep1 rhsOperator - return $ (,) <$> ns <*> pure (dir, i) - -getFixity :: DesugarInfo -> SName -> Fixity -getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm - - ----------------------------------------------------------- operators and identifiers -reservedOp name = lexeme $ try $ string name *> notFollowedBy opLetter +reservedOp name = fst <$> lexeme_ (try $ string name *> notFollowedBy opLetter) -reserved name = lexeme $ try $ string name *> notFollowedBy identLetter +reserved name = fst <$> lexeme_ (try $ string name *> notFollowedBy identLetter) -expect msg p i = i >>= \n -> if p n then unexpected (msg ++ " " ++ show n) else return n +expect :: String -> (String -> Bool) -> Parse r w String -> Parse r w String +expect msg p i = i >>= \n -> if p n then unexpected (Tokens $ fromList n) else return n -identifier ident = lexeme_ $ try $ expect "reserved word" (`Set.member` theReservedNames) ident +identifier :: Parse r w String -> Parse r w SIName +identifier name = lexemeName $ try $ expect "reserved word" (`Set.member` theReservedNames) name -operator oper = lexeme_ $ try $ trCons <$> expect "reserved operator" (`Set.member` theReservedOpNames) oper - where - trCons ":" = "Cons" - trCons x = x +operator :: Parse r w String -> Parse r w SIName +operator name = lexemeName $ try $ expect "reserved operator" (`Set.member` theReservedOpNames) name theReservedOpNames = Set.fromList ["::","..","=","\\","|","<-","->","@","~","=>"] @@ -322,131 +276,34 @@ ,"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 - -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 - -lexeme' sp p = do - p1 <- checkIndent - x <- p - p2 <- getPosition - put p2 - sp - return (RangeSI $ Range p1 p2, x) - -lexeme = fmap snd . lexeme' whiteSpace - -lexeme_ = lexeme' whiteSpace - ----------------------------------------------------------------------- ----------------------------------------------------------------------- --- 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) - -whiteSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment "") - -simpleSpace - = skipSome (satisfy isSpace) - -oneLineComment - = try (string "--" >> many (char '-') >> notFollowedBy opLetter) - >> skipMany (satisfy (/= '\n')) - -multiLineComment = try (string "{-") *> inCommentMulti - -inCommentMulti - = try (() <$ string "-}") - <|> multiLineComment *> inCommentMulti - <|> skipSome (noneOf "{}-") *> inCommentMulti - <|> oneOf "{}-" *> inCommentMulti - "end of comment" - - -parens = between (symbol "(") (symbol ")") -braces = between (symbol "{") (symbol "}") -brackets = between (symbol "[") (symbol "]") - -commaSep p = sepBy p $ symbol "," -commaSep1 p = sepBy1 p $ symbol "," +parseFixity :: Parse r w Fixity +parseFixity = do + dir <- Infix <$ reserved "infix" + <|> InfixL <$ reserved "infixl" + <|> InfixR <$ reserved "infixr" + LInt n <- parseLit + return $ dir $ fromIntegral n -parseLit = lexeme $ charLiteral <|> stringLiteral <|> natFloat +calcPrec + :: (MonadError (f, f){-operator mismatch-} m) + => (f -> e -> e -> e) + -> (f -> Fixity) + -> e + -> [(f, e)] + -> m e +calcPrec app getFixity = compileOps [] 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" - - stringChar = char '\\' *> stringEscape <|> (:[]) <$> satisfy (\c -> c > '\026' && c /= '"') "string character" - - stringEscape = [] <$ some simpleSpace <* (char '\\' "end of string gap") - <|> [] <$ char '&' - <|> (:[]) <$> escapeCode - - -- escape codes - escapeCode = charEsc <|> charNum <|> charAscii <|> char '^' *> charControl "escape code" - - charControl = toEnum . (+ (- fromEnum 'A')) . fromEnum <$> satisfy isUpper "uppercase letter" - - charNum = toEnum . fromInteger <$> (decimal <|> char 'o' *> octal <|> char 'x' *> hexadecimal) - - charEsc = choice $ zipWith (<$) "\a\b\f\n\r\t\v\\\"\'" $ map char "abfnrtv\\\"\'" - - charAscii = choice $ zipWith (<$) ascii $ map (try . string) $ asciicodes - - -- 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'] - - - natFloat = char '0' *> zeroNumFloat <|> decimalFloat - - zeroNumFloat = LInt <$> (oneOf "xX" *> hexadecimal <|> oneOf "oO" *> octal) - <|> decimalFloat - <|> fractFloat 0 - <|> return (LInt 0) - - decimalFloat = decimal >>= \n -> option (LInt n) (fractFloat n) - - fractFloat n = LFloat <$> fractExponent (fromInteger n) - - fractExponent n = (*) <$> ((n +) <$> fraction) <*> option 1.0 exponent' - <|> (n *) <$> exponent' - - fraction = foldr op 0.0 <$ char '.' <*> some digitChar "fraction" - where - op d f = (f + fromIntegral (digitToInt d))/10.0 - - exponent' = (10^^) <$ oneOf "eE" <*> ((negate <$ char '-' <|> id <$ char '+' <|> return id) <*> decimal) "exponent" + compileOps [] e [] = return e + compileOps acc@ ~((op', e'): acc') e es@ ~((op, e''): es') + | c == LT || c == EQ && isInfixL f && isInfixL f' = compileOps acc' (app op' e' e) es + | c == GT || c == EQ && isInfixR f && isInfixR f' = compileOps ((op, e): acc) e'' es' + | otherwise = throwError (op', op) -- operator mismatch + where + isInfixR = \case InfixR{} -> True; _ -> False + isInfixL = \case InfixL{} -> True; _ -> False + f' = getFixity op' + f = getFixity op + c | null es = LT + | null acc = GT + | otherwise = compare (precedence f) (precedence f') 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 @@ -7,1245 +7,576 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} -module LambdaCube.Compiler.Parser - ( SData(..) - , NameDB, caseName, pattern MatchName - , 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 Parens - , pattern TyType, pattern Wildcard_ - , debug, isPi, varDB, lowerDB, upDB, cmpDB, MaxDB(..), iterateN, traceD - , parseLC, runDefParser - , getParamsS, addParamsS, getApps, apps', downToS, addForalls - , Up (..), up1, up - , Doc, shLam, shApp, shLet, shLet_, shAtom, shAnn, shVar, epar, showDoc, showDoc_, sExpDoc, shCstr, shTuple - , mtrace, sortDefs - , trSExp', usedS, substSG0, substS - , Stmt (..), Export (..), ImportItems (..) - ) where - -import Data.Monoid -import Data.Maybe -import Data.List -import Data.Char -import Data.String -import qualified Data.Map as Map -import qualified Data.Set as Set - -import Control.Monad.Except -import Control.Monad.Reader -import Control.Monad.Writer -import Control.Monad.State -import Control.Arrow hiding ((<+>)) -import Control.Applicative - -import qualified LambdaCube.Compiler.Pretty as P -import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) -import LambdaCube.Compiler.Lexer - --------------------------------------------------------------------------------- utils - -(<&>) = flip (<$>) - -dropNth i xs = take i xs ++ drop (i+1) xs -iterateN n f e = iterate f e !! n -mtrace s = trace_ s $ return () - --- supplementary data: data with no semantic relevance -newtype SData a = SData a -instance Show (SData a) where show _ = "SData" -instance Eq (SData a) where _ == _ = True -instance Ord (SData a) where _ `compare` _ = EQ - -traceD x = if debug then trace_ x else id - -debug = False--True--tr - -try = try_ - --------------------------------------------------------------------------------- builtin precedences - -data Prec - = PrecAtom -- ( _ ) ... - | PrecAtom' - | PrecProj -- _ ._ {left} - | PrecSwiz -- _%_ {left} - | PrecApp -- _ _ {left} - | PrecOp - | PrecArr -- _ -> _ {right} - | PrecEq -- _ ~ _ - | PrecAnn -- _ :: _ {right} - | PrecLet -- _ := _ - | PrecLam -- \ _ -> _ {right} {accum} - deriving (Eq, Ord) - --------------------------------------------------------------------------------- expression representation - -type SExp = SExp' Void - -data Void - -instance Show Void where show _ = error "show @Void" -instance Eq Void where _ == _ = error "(==) @Void" - -data SExp' a - = SGlobal SIName - | SBind SI Binder (SData SIName{-parameter's name-}) (SExp' a) (SExp' a) - | SApp SI Visibility (SExp' a) (SExp' a) - | 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) - -pattern SVar a b = SVar_ (SData a) b - -data Binder - = BPi Visibility - | BLam Visibility - | BMeta -- a metavariable is like a floating hidden lambda - deriving (Eq, Show) - -data Visibility = Hidden | Visible - deriving (Eq, Show) - -sLit = SLit mempty -pattern SPi h a b <- SBind _ (BPi h) _ a b where SPi h a b = sBind (BPi h) (SData (debugSI "patternSPi2", "pattern_spi_name")) a b -pattern SLam h a b <- SBind _ (BLam h) _ a b where SLam h a b = sBind (BLam h) (SData (debugSI "patternSLam2", "pattern_slam_name")) a b -pattern Wildcard t <- SBind _ BMeta _ t (SVar _ 0) where Wildcard t = sBind BMeta (SData (debugSI "pattern Wildcard2", "pattern_wildcard_name")) t (SVar (debugSI "pattern Wildcard2", ".wc") 0) -pattern Wildcard_ si t <- SBind _ BMeta _ t (SVar (si, _) 0) -pattern SLamV a = SLam Visible (Wildcard SType) a - -pattern SApp' h a b <- SApp _ h a b where SApp' h a b = sApp h a b -pattern SAppH a b = SApp' Hidden a b -pattern SAppV a b = SApp' Visible a b -pattern SAppV2 f a b = f `SAppV` a `SAppV` b - -pattern SType = SBuiltin "'Type" -pattern SAnn a t = SBuiltin "typeAnn" `SAppH` t `SAppV` a -pattern TyType a = SAnn a SType -pattern SLabelEnd a = SBuiltin "labelend" `SAppV` a - -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 - -isPi (BPi _) = True -isPi _ = False - -infixl 2 `SAppV`, `SAppH` - -addParamsS ps t = foldr (uncurry SPi) t ps - -getParamsS (SPi h t x) = first ((h, t):) $ getParamsS x -getParamsS x = ([], x) - -apps' = foldl $ \a (v, b) -> sApp v a b - -getApps = second reverse . run where - run (SApp _ h a b) = second ((h, b):) $ run a - run x = (x, []) - --- 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 - SGlobal (si, _) -> si - SBind si _ _ e1 e2 -> si - SApp si _ e1 e2 -> si - SLet _ e1 e2 -> sourceInfo e1 <> sourceInfo e2 - SVar (si, _) _ -> si - STyped si _ -> si - SLit si _ -> si - -instance SetSourceInfo (SExp' a) where - setSI si = \case - SBind _ a b c d -> SBind si a b c d - SApp _ a b c -> SApp si a b c - SLet le a b -> SLet le a b - SVar (_, n) i -> SVar (si, n) i - STyped _ t -> STyped si t - SGlobal (_, n) -> SGlobal (si, n) - SLit _ l -> SLit si l - --------------------------------------------------------------------------------- De-Bruijn limit - -newtype MaxDB = MaxDB {getMaxDB :: Int} -- True: closed - -instance Monoid MaxDB where - 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 1 -- - -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 - up1_ :: Int -> a -> a - up1_ = up_ 1 - - fold :: Monoid e => (Int -> Int -> e) -> Int -> a -> e - - used :: Int -> a -> Bool - used = (getAny .) . fold ((Any .) . (==)) - - maxDB_ :: a -> MaxDB - - closedExp :: a -> a - closedExp a = a - -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 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) - -up n = up_ n 0 -up1 = up1_ 0 - -substS j x = mapS' f2 ((+1) *** up 1) (j, x) - where - f2 sn i (j, x) = case compare i j of - GT -> SVar sn $ i - 1 - LT -> SVar sn i - EQ -> STyped (fst sn) x - -foldS h g f = fs - where - fs i = \case - SApp _ _ a b -> fs i a <> fs i b - SLet _ a b -> fs i a <> fs (i+1) b - SBind _ _ _ a b -> fs i a <> fs (i+1) b - STyped si x -> h i si x - SVar sn j -> f sn j i - SGlobal sn -> g sn i - x@SLit{} -> mempty - -freeS = nub . foldS (\_ _ _ -> error "freeS") (\sn _ -> [sn]) mempty 0 - -usedS n = getAny . foldS (\_ _ _ -> error "usedS") (\sn _ -> Any $ n == sn) mempty 0 - -mapS' = mapS__ (\_ _ _ -> error "mapS'") (const . SGlobal) -mapS__ hh gg f2 h = g where - g i = \case - SApp si v a b -> SApp si v (g i a) (g i b) - SLet x a b -> SLet x (g i a) (g (h i) b) - SBind si k si' a b -> SBind si k si' (g i a) (g (h i) b) - SVar sn j -> f2 sn j i - SGlobal sn -> gg sn i - STyped si x -> hh i si x - x@SLit{} -> x - -rearrangeS :: (Int -> Int) -> SExp -> SExp -rearrangeS f = mapS' (\sn j i -> SVar sn $ if j < i then j else i + f (j - i)) (+1) 0 -{- -substS'' :: Int -> Int -> SExp' a -> SExp' a -substS'' j' x = mapS' f2 (+1) j' - where - f2 sn j i - | j < i = SVar sn j - | j == i = SVar sn $ x + (j - j') - | j > i = SVar sn $ j - 1 --} -substSG j = mapS__ (\_ _ _ -> error "substSG") (\sn x -> if sn == j then SVar sn x else SGlobal sn) (\sn j -> const $ SVar sn j) (+1) -substSG0 n = substSG n 0 . up1 - -instance Up Void where - up_ n i = error "up_ @Void" - fold _ = error "fold_ @Void" - maxDB_ _ = error "maxDB @Void" - -instance Up a => Up (SExp' a) where - 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 -dbf_ j xs e = foldl (\e (i, sn) -> substSG sn i e) e $ zip [j..] xs - -dbff :: DBNames -> SExp -> SExp -dbff ns e = foldr substSG0 e ns - -trSExp' = trSExp elimVoid - -elimVoid :: Void -> a -elimVoid _ = error "impossible" - -trSExp :: (a -> b) -> SExp' a -> SExp' b -trSExp f = g where - g = \case - SApp si v a b -> SApp si v (g a) (g b) - SLet x a b -> SLet x (g a) (g b) - SBind si k si' a b -> SBind si k si' (g a) (g b) - SVar sn j -> SVar sn j - SGlobal sn -> SGlobal sn - SLit si l -> SLit si l - STyped si a -> STyped si $ f a - --------------------------------------------------------------------------------- expression parsing - -parseType mb = maybe id option mb (reservedOp "::" *> parseTTerm PrecLam) -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 ((,) <$> pure (mempty, "") <*> parseTTerm PrecAtom) (tvar . pure) mb) - where - 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 - -parseTTerm = typeNS . parseTerm -parseETerm = expNS . parseTerm - -indentation p q = p >> q - -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 - <|> do reserved "forall" - (fe, ts) <- telescope (Just $ Wildcard SType) - f <- SPi . const Hidden <$ reservedOp "." <|> SPi . const Visible <$ reservedOp "->" - t' <- dbf' fe <$> parseTTerm PrecLam - return $ foldr (uncurry f) t' ts - <|> do expNS $ do - (fe, ts) <- reservedOp "\\" *> telescopePat <* reservedOp "->" - checkPattern fe - t' <- dbf' fe <$> parseTerm PrecLam - ge <- dsInfo - return $ foldr (uncurry (patLam id ge)) t' ts - <|> 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)) - PrecAnn -> level PrecOp $ \t -> SAnn t <$> parseType Nothing - PrecOp -> (notOp False <|> notExp) >>= \xs -> join $ calculatePrecs <$> dsInfo <*> pure xs where - 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 <$> (rhsOperator <|> psn ("'EqCTt" <$ reservedOp "~")) - ex pr = pure . Right <$> parseTerm pr - PrecApp -> - 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 (uncurry SLit . second LString <$> lowerCase) (char '.') - PrecAtom -> - mkLit <$> try "literal" parseLit - <|> Wildcard (Wildcard SType) <$ reserved "_" - <|> 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 . 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 - sc c = SBuiltin ['S',c] - swizzcall [x] = SBuiltin "swizzscalar" `SAppV` term `SAppV` (sc . synonym) x - swizzcall xs = SBuiltin "swizzvector" `SAppV` term `SAppV` swizzparam xs - swizzparam xs = foldl SAppV (vec xs) $ map (sc . synonym) xs - vec xs = SBuiltin $ case length xs of - 0 -> error "impossible: swizzling parsing returned empty pattern" - 1 -> error "impossible: swizzling went to vector for one scalar" - n -> "V" ++ show n - synonym 'r' = 'x' - synonym 'g' = 'y' - synonym 'b' = 'z' - synonym 'a' = 'w' - synonym c = c - - mkProjection = foldl $ \exp field -> SBuiltin "project" `SAppV` field `SAppV` exp - - -- 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 (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 "HCons" `SAppV` x `SAppV` xs) - (SBuiltin "HNil") - - mkTuple _ [Section e] = e - 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 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 - - mkIf b t f = SBuiltin "primIfThenElse" `SAppV` b `SAppV` t `SAppV` f - - mkDotDot e f = SBuiltin "fromTo" `SAppV` e `SAppV` f - - calculatePrecs :: DesugarInfo -> [Either SIName SExp] -> P SExp - calculatePrecs dcls = either fail return . f where - f [] = error "impossible" - f (Right t: xs) = either (\(op, xs) -> Section $ SLamV $ SGlobal op `SAppV` up1 (calcPrec' t xs) `SAppV` SVar (mempty, ".rs") 0) (calcPrec' t) <$> cont xs - f xs@(Left op@(_, "-"): _) = f $ Right (mkLit $ LInt 0): xs - f (Left op: xs) = g op xs >>= either (const $ Left "TODO: better error message @476") - (\((op, e): oe) -> return $ Section $ SLamV $ SGlobal op `SAppV` SVar (mempty, ".ls") 0 `SAppV` up1 (calcPrec' e oe)) - g op (Right t: xs) = (second ((op, t):) +++ ((op, t):)) <$> cont xs - g op [] = return $ Left (op, []) - g op _ = Left "two operator is not allowed next to each-other" - cont (Left op: xs) = g op xs - cont [] = return $ Right [] - cont _ = error "impossible" - - calcPrec' = calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) (getFixity dcls . snd) - - generator, letdecl, boolExpression :: P (SExp -> SExp) - generator = do - ge <- dsInfo - (dbs, pat) <- try "generator" $ longPattern <* reservedOp "<-" - checkPattern dbs - exp <- parseTerm PrecLam - return $ \e -> - SBuiltin "concatMap" - `SAppV` SLamV (compileGuardTree id id ge $ Alts - [ compilePatts [(pat, 0)] $ Right $ dbff dbs e - , GuardLeaf $ SBuiltin "Nil" - ]) - `SAppV` exp - - letdecl = mkLets <$ reserved "let" <*> dsInfo <*> (compileFunAlts' =<< valueDef) - - boolExpression = (\pred e -> SBuiltin "primIfThenElse" `SAppV` pred `SAppV` e `SAppV` SBuiltin "Nil") <$> parseTerm PrecLam - - - mkPi Hidden (getTTuple' -> xs) b = foldr (sNonDepPi Hidden) b xs - mkPi h a b = sNonDepPi h a b - - sNonDepPi h a b = SPi h a $ up1 b - -getTTuple' (SBuiltin "'HList" `SAppV` (getTTuple -> Just (n, xs))) | n == length xs = xs -getTTuple' x = [x] - -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 -patLam f ge (v, t) p e = SLam v t $ compileGuardTree f f ge $ compilePatts [(p, 0)] $ Right e - --------------------------------------------------------------------------------- pattern representation - -data Pat - = PVar SIName -- Int - | PCon SIName [ParPat] - | ViewPat SExp ParPat - | 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 - -mapPP f = \case - ParPat ps -> ParPat (mapP f <$> ps) - -mapP :: (SExp -> SExp) -> Pat -> Pat -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) - ---upP i j = mapP (up_ j i) - -varPP = length . getPPVars_ -varP = length . getPVars_ - -type DBNames = [SIName] -- De Bruijn variable names - -getPVars :: Pat -> DBNames -getPVars = reverse . getPVars_ - -getPPVars = reverse . getPPVars_ - -getPVars_ = \case - PVar n -> [n] - PCon _ pp -> foldMap getPPVars_ pp - PParens p -> getPVars_ p - ViewPat e pp -> getPPVars_ pp - PatType pp e -> getPPVars_ pp - -getPPVars_ = \case - ParPat pp -> foldMap getPVars_ pp - -instance SourceInfo ParPat where - sourceInfo (ParPat ps) = sourceInfo ps - -instance SourceInfo Pat where - sourceInfo = \case - PVar (si,_) -> si - PCon (si,_) ps -> si <> sourceInfo ps - ViewPat e ps -> sourceInfo e <> sourceInfo ps - PatType ps e -> sourceInfo ps <> sourceInfo e - --------------------------------------------------------------------------------- pattern parsing - -parsePat :: Prec -> P Pat -parsePat = \case - PrecAnn -> - patType <$> parsePat PrecOp <*> parseType (Just $ Wildcard SType) - PrecOp -> - calculatePatPrecs <$> dsInfo <*> p_ - where - 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 <$> upperCase_ <*> many (ParPat . pure <$> parsePat PrecAtom) - <|> parsePat PrecAtom - PrecAtom -> - mkLit <$> namespace <*> try "literal" parseLit - <|> flip PCon [] <$> upperCase_ - <|> char '\'' *> switchNS (parsePat PrecAtom) - <|> 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 TypeNS (LInt n) = toNatP n -- todo: elim this alternative - mkLit _ n@LInt{} = litP (SBuiltin "fromInt" `SAppV` sLit n) - mkLit _ n = litP (sLit n) - - toNatP = run where - run 0 = PCon (mempty, "Zero") [] - run n | n > 0 = PCon (mempty, "Succ") [ParPat [run $ n-1]] - - pConSI (PCon (_, n) ps) = PCon (sourceInfo ps, n) ps - pConSI p = p - - patlist = commaSep $ parsePat PrecAnn - - 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 [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 - - calculatePatPrecs dcls (e, xs) = calcPrec (\op x y -> PCon op $ ParPat . (:[]) <$> [x, y]) (getFixity dcls . snd) e xs - -longPattern = parsePat PrecAnn <&> (getPVars &&& id) ---patternAtom = parsePat PrecAtom <&> (getPVars &&& id) - -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) - -checkPattern :: DBNames -> P () -checkPattern ns = lift $ tell $ pure $ - case [ns' | ns' <- group . sort . filter (not . null . snd) $ ns - , not . null . tail $ ns'] of - [] -> Nothing - xs -> Just $ "multiple pattern vars:\n" ++ unlines [n ++ " is defined at " ++ ppShow si | ns <- xs, (si, n) <- ns] - - --------------------------------------------------------------------------------- pattern match compilation - -data GuardTree - = GuardNode SExp SName [ParPat] GuardTree -- _ <- _ - | Alts [GuardTree] -- _ | _ - | GuardLeaf SExp -- _ -> e - deriving Show - -alts (Alts xs) = concatMap alts xs -alts x = [x] - -mapGT k i = \case - GuardNode e c pps gt -> GuardNode (i k e) c {-todo: up-}pps $ mapGT (k + sum (map varPP pps)) i gt - Alts gts -> Alts $ map (mapGT k i) gts - GuardLeaf e -> GuardLeaf $ i k e - -upGT k i = mapGT k $ \k -> up_ i k - -substGT i j = mapGT 0 $ \k -> rearrangeS $ \r -> if r == k + i then k + j else if r > k + i then r - 1 else r -{- -dbfGT :: DBNames -> GuardTree -> GuardTree -dbfGT v = mapGT 0 $ \k -> dbf_ k v --} --- todo: clenup -compilePatts :: [(Pat, Int)] -> Either [(SExp, SExp)] SExp -> GuardTree -compilePatts ps gu = cp [] ps - where - cp ps' [] = case gu of - Right e -> GuardLeaf $ rearrangeS (f $ reverse ps') e - Left gs -> Alts - [ GuardNode (rearrangeS (f $ reverse ps') ge) "True" [] $ GuardLeaf $ rearrangeS (f $ reverse ps') e - | (ge, e) <- gs - ] - 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 - - ff PVar{} = Nothing - ff p = Just $ varP p - - f ps i - | i >= s = i - s + m + sum vs' - | i < s = case vs_ !! n of - Nothing -> m + sum vs' - 1 - n - Just _ -> m + sum vs' - 1 - (m + sum (take n vs') + j) - where - i' = s - 1 - i - (n, j) = concat (zipWith (\k j -> zip (repeat j) [0..k-1]) vs [0..]) !! i' - - vs_ = map ff ps - vs = map (fromMaybe 1) vs_ - vs' = map (fromMaybe 0) vs_ - s = sum vs - -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 - where - guardTreeToCases :: GuardTree -> SExp - guardTreeToCases t = case alts t of - [] -> ulend $ SBuiltin "undefined" - GuardLeaf e: _ -> lend e - ts@(GuardNode f s _ _: _) -> case Map.lookup s (snd adts) of - Nothing -> error $ "Constructor is not defined: " ++ s - 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 - ] - `SAppV` f - Just (Right n) -> SGlobal (debugSI "compileGuardTree3", MatchName s) - `SAppV` SLamV (Wildcard SType) - `SAppV` iterateN n SLamV (guardTreeToCases $ Alts $ map (filterGuardTree (up n f) s 0 n . upGT 0 n) ts) - `SAppV` f - `SAppV` guardTreeToCases (Alts $ map (filterGuardTree' f s) ts) - - filterGuardTree :: SExp -> SName{-constr.-} -> Int -> Int{-number of constr. params-} -> GuardTree -> GuardTree - filterGuardTree f s k ns = \case - GuardLeaf e -> GuardLeaf e - Alts ts -> Alts $ map (filterGuardTree f s k ns) ts - GuardNode f' s' ps gs - | f /= f' -> GuardNode f' s' ps $ filterGuardTree (up su f) s (su + k) ns gs - | s == s' -> filterGuardTree f s k ns $ guardNodes (zips [k+ns-1, k+ns-2..] ps) gs - | otherwise -> Alts [] - where - zips is ps = zip (map (SVar (debugSI "30", ".30")) $ zipWith (+) is $ sums $ map varPP ps) ps - su = sum $ map varPP ps - sums = scanl (+) 0 - - filterGuardTree' :: SExp -> SName{-constr.-} -> GuardTree -> GuardTree - filterGuardTree' f s = \case - GuardLeaf e -> GuardLeaf e - Alts ts -> Alts $ map (filterGuardTree' f s) ts - GuardNode f' s' ps gs - | f /= f' || s /= s' -> GuardNode f' s' ps $ filterGuardTree' (up su f) s gs - | otherwise -> Alts [] - where - su = sum $ map varPP ps - - guardNodes :: [(SExp, ParPat)] -> GuardTree -> GuardTree - guardNodes [] l = l - guardNodes ((v, ParPat ws): vs) e = guardNode v ws $ guardNodes vs e - - guardNode :: SExp -> [Pat] -> GuardTree -> GuardTree - guardNode v [] e = e - guardNode v [w] e = case w of - PVar _ -> {-todo guardNode v (subst x v ws) $ -} varGuardNode 0 v 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 - -compileCase ge x cs - = SLamV (compileGuardTree id id ge $ Alts [compilePatts [(p, 0)] e | (p, e) <- cs]) `SAppV` x - - --------------------------------------------------------------------------------- declaration representation - -data Stmt - = 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 - - -- eliminated during parsing - | TypeFamily SIName [(Visibility, SExp)]{-parameters-} SExp{-type-} - | Class SIName [SExp]{-parameters-} [(SIName, SExp)]{-method names and types-} - | Instance SIName [Pat]{-parameter patterns-} [SExp]{-constraints-} [Stmt]{-method definitions-} - | TypeAnn SIName SExp -- intermediate - | FunAlt SIName [((Visibility, SExp), Pat)] (Either [(SExp, SExp)]{-guards-} SExp{-no guards-}) - deriving (Show) - -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 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 "a1" (length ts') $ length ts) ts') - (af, cs) <- option (True, []) $ - do fmap ((,) True) $ (reserved "where" >>) $ indentMS True $ second ((,) Nothing . dbf' npsd) <$> typedIds Nothing - <|> (,) False <$ reservedOp "=" <*> - 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..]) - <$> telescope Nothing - ) - (reservedOp "|") - mkData <$> dsInfo <*> pure x <*> pure ts <*> pure t <*> pure af <*> pure (concatMap (\(vs, t) -> (,) <$> vs <*> pure t) cs) - <|> do reserved "class" *> do - x <- typeNS upperCase - (nps, ts) <- telescope (Just SType) - 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 <- upperCase - (nps, args) <- telescopePat - 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 <- upperCase - (nps, ts) <- telescope (Just SType) - t <- dbf' nps <$> parseType (Just SType) - option {-open type family-}[TypeFamily x ts t] $ do - cs <- (reserved "where" >>) $ indentMS True $ funAltDef $ mfilter (== x) upperCase - -- closed type family desugared here - 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 <- upperCase - (nps, ts) <- telescope $ Just (Wildcard SType) - rhs <- dbf' nps <$ reservedOp "=" <*> parseTerm PrecLam - 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 - <|> map (uncurry PrecDef) <$> parseFixityDecl - <|> pure <$> funAltDef varId - <|> valueDef - where - telescopeDataFields :: P ([SIName], [(Visibility, SExp)]) - 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 - mkProj fn - = [ FunAlt fn [((Visible, Wildcard SType), PCon cn $ replicate (length fs) $ ParPat [PVar (mempty, "generated_name1")])] $ Right $ SVar (mempty, ".proj") i - | (cn, (Just fs, _)) <- cs, (i, fn') <- zip [0..] fs, fn' == fn - ] - - -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 <$ reserved "where" <*> dsInfo <*> parseDefs - return $ Right $ f rhs - -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 - 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 <- parseName - (,) n <$> telescopePat <* lookAhead (reservedOp "=" <|> reservedOp "|") - checkPattern fee - FunAlt n tss <$> parseRHS (dbf' fee) "=" - -valueDef :: P [Stmt] -valueDef = do - (dns, p) <- try "pattern" $ longPattern <* reservedOp "=" - checkPattern dns - e <- parseETerm PrecLam - ds <- dsInfo - return $ desugarValueDef ds p e - -desugarValueDef ds p e - = FunAlt n [] (Right e) - : [ FunAlt x [] $ Right $ compileCase ds (SGlobal n) [(p, Right $ SVar x i)] - | (i, x) <- zip [0..] dns - ] - where - dns = getPVars p - n = mangleNames dns - -mangleNames xs = (foldMap fst xs, "_" ++ intercalate "_" (map snd xs)) -{- -parseSomeGuards f = do - pos <- sourceColumn <$> getPosition <* reservedOp "|" - guard $ f pos - (e', f) <- - do (e', PCon (_, p) vs) <- try "pattern" $ longPattern <* reservedOp "<-" - checkPattern e' - x <- parseETerm PrecOp - return (e', \gs' gs -> GuardNode x p vs (Alts gs'): gs) - <|> do x <- parseETerm PrecOp - return (mempty, \gs' gs -> [GuardNode x "True" [] $ Alts gs', GuardNode x "False" [] $ Alts gs]) - f <$> ((map (dbfGT e') <$> parseSomeGuards (> pos)) <|> (:[]) . GuardLeaf <$ reservedOp "->" <*> (dbf' e' <$> parseETerm PrecLam)) - <*> option [] (parseSomeGuards (== pos)) --} -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] - where - f e v = SPi Hidden (Wildcard SType) $ substSG0 v e - - notElem' s@('\'':s') m = notElem s m && notElem s' m - notElem' s m = s `notElem` m -{- -defined defs = ("'Type":) $ flip foldMap defs $ \case - TypeAnn (_, x) _ -> [x] - Let (_, x) _ _ _ _ -> [x] - Data (_, x) _ _ _ cs -> x: map (snd . fst) cs - Class (_, x) _ cs -> x: map (snd . fst) cs - TypeFamily (_, x) _ _ -> [x] - x -> error $ unwords ["defined: Impossible", show x, "cann't be here"] --} - --------------------------------------------------------------------------------- declaration desugaring - -sortDefs ds xs = concatMap (desugarMutual ds) $ topSort mempty mempty mempty nodes - where - nodes = zip (zip [0..] xs) $ map (def &&& need) xs - need = \case - PrecDef{} -> mempty - 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 - 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 - topSort [] _ vs [] | Set.null vs = [] - topSort acc defs vs (x@((i, v), (d, u)): ns) - | i `elem` vs || all (`elem` defs) u = topSort (v: acc) (d <> defs) (Set.delete i vs) ns - | otherwise = topSort acc defs (Set.insert i vs) $ let - (ns1, ns2) = span (\(_, (d, _)) -> not $ Set.null $ d `Set.intersection` u) ns - in ns1 ++ x: ns2 - -desugarMutual _ [x] = [x] -desugarMutual ds xs = xs -{- - = FunAlt n [] (Right e) - : [ FunAlt x [] $ Right $ compileCase ds (SGlobal n) [(p, Right $ SVar x i)] - | (i, x) <- zip [0..] dns - ] - where - dns = getPVars p - n = mangleNames dns - (ps, es) = unzip [(n, e) | Let n ~Nothing ~Nothing [] e <- xs] - tup = "Tuple" ++ show (length xs) - e = dbf' ps $ foldl SAppV (SBuiltin tup) es - p = PCon (mempty, tup) $ map (ParPat . pure . PVar) ps --} - - -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 compilegt ds xs = dsInfo >>= \ge -> case xs of - [Instance{}] -> return [] - [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 ???")] - 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 - ] - ] - 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 $ 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] - | num == 0 && length fs > 1 -> fail $ "redefined " ++ snd n ++ " at " ++ ppShow (fst n) - | n `elem` [n' | TypeFamily n' _ _ <- ds] -> return [] - | otherwise -> return - [ Let n - (listToMaybe [t | TypeAnn n' t <- ds, n' == n]) - $ foldr (uncurry SLam . fst) (compilegt ge - [ compilePatts (zip (map snd vs) $ reverse [0.. num - 1]) gsx - | FunAlt _ vs gsx <- fs - ]) vs - ] - _ -> fail $ "different number of arguments of " ++ snd n ++ " at " ++ ppShow (fst n) - x -> return x - where - noTA x = ((Visible, Wildcard SType), x) - -dbFunAlt v (FunAlt n ts gue) = FunAlt n (map (second $ mapP (dbf' v)) ts) $ fmap (dbf' v *** dbf' v) +++ dbf' v $ gue - - --------------------------------------------------------------------------------- desugar info - -mkDesugarInfo :: [Stmt] -> DesugarInfo -mkDesugarInfo ss = - ( Map.fromList $ ("'EqCTt", (Infix, -1)): [(s, f) | PrecDef (_, s) f <- ss] - , Map.fromList $ - [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 - - hackHList ("HCons", _) = ("HCons", Left (("hlistConsCase", -1), [("HCons", 2)])) - hackHList ("HNil", _) = ("HNil", Left (("hlistNilCase", -1), [("HNil", 0)])) - hackHList x = x - --------------------------------------------------------------------------------- module exports - -data Export = ExportModule SIName | ExportId SIName - -parseExport :: Namespace -> P Export -parseExport ns = - ExportModule <$ reserved "module" <*> moduleName - <|> ExportId <$> varId - --------------------------------------------------------------------------------- module imports - -data ImportItems - = ImportAllBut [SIName] - | ImportJust [SIName] - -importlist = parens $ commaSep upperLower - --------------------------------------------------------------------------------- language pragmas - -type Extensions = [Extension] - -data Extension - = NoImplicitPrelude - | TraceTypeCheck - deriving (Enum, Eq, Ord, Show) - -extensionMap :: Map.Map String Extension -extensionMap = Map.fromList $ map (show &&& id) [toEnum 0 .. ] - -parseExtensions :: P [Extension] -parseExtensions - = try "pragma" (symbol "{-#") *> symbol "LANGUAGE" *> commaSep (lexeme ext) <* symbol' simpleSpace "#-}" - where - ext = do - s <- some $ satisfy isAlphaNum - maybe - (fail $ "language extension expected instead of " ++ s) - return - (Map.lookup s extensionMap) - --------------------------------------------------------------------------------- modules - -data Module - = Module - { extensions :: Extensions - , moduleImports :: [(SIName, ImportItems)] - , moduleExports :: Maybe [Export] - , definitions :: DefParser - } - -type DefParser = DesugarInfo -> (Either ParseError [Stmt], [PostponedCheck]) - -parseModule :: FilePath -> String -> P Module -parseModule f str = do - exts <- concat <$> many parseExtensions - whiteSpace - header <- optional $ do - modn <- reserved "module" *> moduleName - exps <- optional (parens $ commaSep $ parseExport ExpNS) - reserved "where" - return (modn, exps) - let mkIDef _ n i h _ = (n, f i h) - where - f Nothing Nothing = ImportAllBut [] - f (Just h) Nothing = ImportAllBut h - f Nothing (Just i) = ImportJust i - idefs <- many $ - mkIDef <$ reserved "import" - <*> optional (reserved "qualified") - <*> moduleName - <*> optional (reserved "hiding" *> importlist) - <*> optional importlist - <*> optional (reserved "as" *> moduleName) - st <- getParserState - return Module - { extensions = exts - , moduleImports = [((mempty, "Prelude"), ImportAllBut []) | NoImplicitPrelude `notElem` exts] ++ idefs - , moduleExports = join $ snd <$> header - , definitions = \ge -> first snd $ runP' (ge, ExpNS) f (parseDefs <* eof) st - } - -parseLC :: FilePath -> String -> Either ParseError Module -parseLC f str - = 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 - pShowPrec _ = showDoc_ . sExpDoc - -type Doc = NameDB PrecString - --- name De Bruijn indices -type NameDB a = StateT [String] (Reader [String]) a - -showDoc :: Doc -> String -showDoc = str . flip runReader [] . flip evalStateT (flip (:) <$> iterate ('\'':) "" <*> ['a'..'z']) - -showDoc_ :: Doc -> P.Doc -showDoc_ = text . str . flip runReader [] . flip evalStateT (flip (:) <$> iterate ('\'':) "" <*> ['a'..'z']) - -sExpDoc :: Up a => SExp' a -> Doc -sExpDoc = \case - SGlobal (_,s) -> pure $ shAtom s - SAnn a b -> shAnn ":" False <$> sExpDoc a <*> sExpDoc b - TyType a -> shApp Visible (shAtom "tyType") <$> sExpDoc a - SApp _ h a b -> shApp h <$> sExpDoc a <*> sExpDoc b - Wildcard t -> shAnn ":" True (shAtom "_") <$> sExpDoc t - SBind _ h _ a b -> join $ shLam (used 0 b) h <$> sExpDoc a <*> pure (sExpDoc b) - SLet _ a b -> shLet_ (sExpDoc a) (sExpDoc b) - STyped _ _{-(e,t)-} -> pure $ shAtom "<<>>" -- todo: expDoc e - SVar _ i -> shAtom <$> shVar i - SLit _ l -> pure $ shAtom $ show l - -shVar i = asks lookupVarName where - lookupVarName xs | i < length xs && i >= 0 = xs !! i - lookupVarName _ = "V" ++ show i - -newName = gets head <* modify tail - -shLet i a b = shAtom <$> shVar i >>= \i' -> local (dropNth i) $ shLam' <$> (cpar . shLet' (fmap inBlue i') <$> a) <*> b -shLet_ a b = newName >>= \i -> shLam' <$> (cpar . shLet' (shAtom i) <$> a) <*> local (i:) b -shLam used h a b = newName >>= \i -> - let lam = case h of - BPi _ -> shArr - _ -> shLam' - p = case h of - BMeta -> cpar . shAnn ":" True (shAtom $ inBlue i) - BLam h -> vpar h - BPi h -> vpar h - vpar Hidden = brace . shAnn ":" True (shAtom $ inGreen i) - vpar Visible = ann (shAtom $ inGreen i) - ann | used = shAnn ":" False - | otherwise = const id - in lam (p a) <$> local (i:) b - ------------------------------------------ - -data PS a = PS Prec a deriving (Functor) -type PrecString = PS String - -getPrec (PS p _) = p -prec i s = PS i (s i) -str (PS _ s) = s - -lpar, rpar :: PrecString -> Prec -> String -lpar (PS i s) j = par (i >. j) s where - PrecLam >. i = i > PrecAtom' - i >. PrecLam = i >= PrecArr - PrecApp >. PrecApp = False - i >. j = i >= j -rpar (PS i s) j = par (i >. j) s where - PrecLam >. PrecLam = False - PrecLam >. i = i > PrecAtom' - PrecArr >. PrecArr = False - PrecAnn >. PrecAnn = False - i >. j = i >= j - -par True s = "(" ++ s ++ ")" -par False s = s - -isAtom = (==PrecAtom) . getPrec -isAtom' = (<=PrecAtom') . getPrec - -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 -shApp Hidden x y = prec PrecApp $ lpar x <> " " <> const (str $ brace y) -shApp h x y = prec PrecApp $ lpar x <> " " <> rpar y -shArr x y | isAtom x && isAtom y = shAtom' $ str x <> "->" <> str y -shArr x y = prec PrecArr $ lpar x <> " -> " <> rpar y -shCstr x y | isAtom x && isAtom y = shAtom' $ str x <> "~" <> str y -shCstr x y = prec PrecEq $ lpar x <> " ~ " <> rpar y -shLet' x y | isAtom x && isAtom y = shAtom' $ str x <> ":=" <> str y -shLet' x y = prec PrecLet $ lpar x <> " := " <> rpar y -shLam' x y | PrecLam <- getPrec y = prec PrecLam $ "\\" <> lpar x <> " " <> pure (dropC $ str y) - where - dropC (ESC s (dropC -> x)) = ESC s x - dropC (x: xs) = xs -shLam' x y | isAtom x && isAtom y = shAtom' $ "\\" <> str x <> "->" <> str y -shLam' x y = prec PrecLam $ "\\" <> lpar x <> " -> " <> rpar y -brace s = shAtom $ "{" <> str s <> "}" -cpar s | isAtom' s = s -- TODO: replace with lpar, rpar -cpar s = shAtom $ par True $ str s -epar = fmap underlined - -instance IsString (Prec -> String) where fromString = const +{-# LANGUAGE TypeFamilies #-} +module LambdaCube.Compiler.Parser + ( parseLC + , runDefParser + , ParseWarning (..) + , DesugarInfo + , Module + ) where + +import Data.Monoid +import Data.Maybe +import Data.List +import Data.Char +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.RWS +import Control.Arrow hiding ((<+>)) +import Control.Applicative + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) +import LambdaCube.Compiler.Lexer +import LambdaCube.Compiler.DesugaredSource +import LambdaCube.Compiler.Patterns +import LambdaCube.Compiler.Statements + +-------------------------------------------------------------------------------- parser type + +type BodyParser = Parse DesugarInfo PostponedCheck + +type PostponedCheck = Either (Maybe LCParseError) ParseCheck + +runCheck :: Parse DesugarInfo ParseCheck a -> BodyParser a +runCheck = mapRWST $ fmap $ \(a, b, c) -> (a, b, Right <$> c) + +data LCParseError + = MultiplePatternVars [[SIName]] + | OperatorMismatch SIName SIName + | UndefinedConstructor SIName + | ParseError ParseError + +data ParseWarning + = Unreachable Range + | Uncovered SIName [PatList] + +instance PShow LCParseError where + pShow = \case + MultiplePatternVars xs -> vcat $ "multiple pattern vars:": + concat [(shortForm (pShow $ head ns) <+> "is defined at"): map pShow ns | ns <- xs] + OperatorMismatch op op' -> "Operator precedences don't match:" <$$> pShow (fromJust $ nameFixity op) <+> "at" <+> pShow op <$$> pShow (fromJust $ nameFixity op') <+> "at" <+> pShow op' + UndefinedConstructor n -> "Constructor" <+> shortForm (pShow n) <+> "is not defined at" <+> pShow n + ParseError p -> text $ show p + +instance PShow ParseWarning where + pShow = \case + Unreachable si -> "Source code is not reachable:" <+> pShow si + Uncovered sn pss -> "Uncovered pattern(s) at" <+> pShow (sourceInfo sn) <$$> + nest 4 (shortForm $ vcat $ "Missing case(s):" : + [ addG (foldl DApp (pShow sn) (pShow <$> ps)) [DOp "<-" (Infix (-1)) (pShow p) (pShow e) | (p, e) <- gs] + | (ps, gs) <- pss] + ) + where + addG x [] = x + addG x xs = DOp "|" (Infix (-5)) x $ foldr1 (DOp "," (InfixR (-4))) xs + +trackSI p = do + x <- p + tell $ Right . TrackedCode <$> maybeToList (getRange $ sourceInfo x) + return x + +addFixity :: BodyParser SIName -> BodyParser SIName +addFixity p = f <$> asks (fixityMap . desugarInfo) <*> p + where + f fm sn@(SIName_ si _ n) = SIName_ si (Just $ defaultFixity $ Map.lookup n fm) n + +addFixity' :: BodyParser SIName -> BodyParser SIName +addFixity' p = f <$> asks (fixityMap . desugarInfo) <*> p + where + f fm sn@(SIName_ si _ n) = SIName_ si (Map.lookup n fm) n + +addConsInfo p = join $ f <$> asks (consMap . desugarInfo) <*> p + where + f adts s = do + tell [Left $ either (Just . UndefinedConstructor) (const Nothing) x] + return $ either (const $ error "impossible @ Parser 826") id x + where + x = case Map.lookup (sName s) adts of + Nothing -> throwError s + Just i -> return (s, i) + +addForalls' :: BodyParser SExp -> BodyParser SExp +addForalls' p = addForalls_ mempty <*> p + +addForalls_ s = addForalls . (Set.fromList (sName <$> s) <>) <$> asks (definedSet . desugarInfo) + +-------------------------------------------------------------------------------- desugar info + +-- TODO: filter this in module imports +data DesugarInfo = DesugarInfo + { fixityMap :: Map.Map SName Fixity + , consMap :: Map.Map SName ConsInfo + , definedSet :: DefinedSet + } + +instance Monoid DesugarInfo where + mempty = DesugarInfo mempty mempty mempty + DesugarInfo a b c `mappend` DesugarInfo a' b' c' = DesugarInfo (a <> a') (b <> b') (c <> c') + +mkDesugarInfo :: [Stmt] -> DesugarInfo +mkDesugarInfo ss = DesugarInfo + { fixityMap = Map.fromList $ ("'EqCTt", Infix (-1)): [(sName s, f) | PrecDef s f <- ss] + , consMap = Map.fromList $ + [(sName cn, Left ((CaseName $ sName t, pars ty), second pars <$> cs)) | Data t ps ty cs <- ss, (cn, ct) <- cs] + ++ [(sName t, Right $ pars $ UncurryS ps ty) | Data t ps ty _ <- ss] +-- ++ [(t, Right $ length xs) | StLet (_, t) _ (Just ty) xs _ <- ss] + ++ [("'Type", Right 0)] + , definedSet = Set.singleton "'Type" <> foldMap defined ss + } + where + pars (UncurryS l _) = length $ filter ((== Visible) . fst) l -- todo + + defined = \case + StLet sn _ _ -> Set.singleton $ sName sn + Data sn _ _ cs -> Set.fromList $ sName sn: map (sName . fst) cs + PrecDef{} -> mempty + +-------------------------------------------------------------------------------- expression parsing + +hiddenTerm p q = (,) Hidden <$ reservedOp "@" <*> typeNS p <|> (,) Visible <$> q + +parseType mb = maybe id option mb (reservedOp "::" *> typeNS (setR parseTermLam)) + +typedIds f ds = (\ns t -> (,) <$> ns <*> pure t) <$> commaSep1 upperLower <*> (deBruijnify (ds :: [SIName]) <$> f (parseType Nothing)) + +telescope mb = fmap mkTelescope $ many $ hiddenTerm + (typedId <|> maybe empty (tvar . pure) mb) + (try_ "::" typedId <|> maybe ((,) (SIName mempty "") <$> typeNS (setR parseTermAtom)) (tvar . pure) mb) + where + tvar x = (,) <$> patVar <*> x + typedId = parens $ tvar $ parseType mb + +mkTelescope (unzip -> (vs, ns)) = second (zip vs) $ mkTelescope' $ first (:[]) <$> ns + +mkTelescope' = go [] + where + go ns [] = (ns, []) + go ns ((n, e): ts) = second (deBruijnify ns e:) $ go (n ++ ns) ts + +--parseTerm... :: BodyParser SExp +parseTermLam = + do level parseTermAnn $ \t -> + mkPi <$> (Visible <$ reservedOp "->" <|> Hidden <$ reservedOp "=>") <*> pure t <*> setR parseTermLam + <|> mkIf <$ reserved "if" <*> setR parseTermLam + <* reserved "then" <*> setR parseTermLam + <* reserved "else" <*> setR parseTermLam + <|> do (fe, ts) <- reserved "forall" *> telescope (Just $ Wildcard SType) + f <- SPi . const Hidden <$ reservedOp "." <|> SPi . const Visible <$ reservedOp "->" + t' <- deBruijnify fe <$> setR parseTermLam + return $ foldr (uncurry f) t' ts + <|> do expNS $ do + (fe, ts) <- reservedOp "\\" *> telescopePat <* reservedOp "->" + foldr (\e m -> runCheck . uncurry (patLam id) e =<< m) (deBruijnify fe <$> setR parseTermLam) ts + <|> do join $ (runCheck .) . compileCase <$ reserved "case" <*> setR parseTermLam <* reserved "of" <*> do + identation False $ do + (fe, p) <- longPattern + (,) p . deBruijnify fe <$> parseRHS "->" + where + mkIf b t f = SBuiltin FprimIfThenElse `SAppV` b `SAppV` t `SAppV` f + + mkPi Hidden xs b = foldr (\a b -> SPi Hidden a $ up1 b) b $ map SCW $ getTTuple xs + mkPi Visible a b = SPi Visible a $ up1 b + +parseTermAnn = level parseTermOp $ \t -> SAnn t <$> parseType Nothing + +parseTermOp = (notOp False <|> notExp) >>= calculatePrecs + where + notExp = (++) <$> ope <*> notOp True + notOp x = (++) <$> try_ "expression" ((++) <$> ex parseTermApp <*> option [] ope) <*> notOp True + <|> if x then option [] (try_ "lambda" $ ex parseTermLam) else mzero + ope = pure . Left <$> addFixity (rhsOperator <|> appRange (flip SIName "'EqCTt" <$ reservedOp "~")) + ex pr = pure . Right <$> setR pr + + calculatePrecs :: [Either SIName SExp] -> BodyParser SExp + calculatePrecs = go where + + go (Right e: xs) = waitOp False e [] xs + go xs@(Left (sName -> "-"): _) = waitOp False (mkLit $ LInt 0) [] xs + go (Left op: xs) = Section . SLamV <$> waitExp True (sVar "leftSection" 0) [] op xs + go _ = error "impossible @ Parser 479" + + waitExp lsec e acc op (Right t: xs) = waitOp lsec e ((op, if lsec then up 1 t else t): acc) xs + waitExp lsec e acc op [] | lsec = fail "two-sided section is not allowed" + | otherwise = fmap (Section . SLamV) . calcPrec' e $ (op, sVar "rightSection" 0): map (second (up 1)) acc + waitExp _ _ _ _ _ = fail "two operator is not allowed next to each-other" + + waitOp lsec e acc (Left op: xs) = waitExp lsec e acc op xs + waitOp lsec e acc [] = calcPrec' e acc + waitOp lsec e acc _ = error "impossible @ Parser 488" + + calcPrec' e = postponedCheck id . calcPrec (\op x y -> SGlobal op `SAppV` x `SAppV` y) (fromJust . nameFixity) e . reverse + +parseTermApp = + AppsS <$> try_ "record" (SGlobal <$> upperCase <* symbol "{") + <*> commaSep ((,) Visible <$ lowerCase{-TODO-} <* reservedOp "=" <*> setR parseTermLam) + <* symbol "}" + <|> AppsS <$> setR parseTermSwiz <*> many (hiddenTerm (setR parseTermSwiz) $ setR parseTermSwiz) + +parseTermSwiz = level parseTermProj $ \t -> + mkSwizzling t <$> lexeme (try_ "swizzling" $ char '%' *> count' 1 4 (satisfy (`elem` ("xyzwrgba" :: String)))) + where + mkSwizzling term = swizzcall . map (SBuiltin . sc . synonym) + where + swizzcall [] = error "impossible: swizzling parsing returned empty pattern" + swizzcall [x] = SBuiltin Fswizzscalar `SAppV` term `SAppV` x + swizzcall xs = SBuiltin Fswizzvector `SAppV` term `SAppV` foldl SAppV (SBuiltin $ f (length xs)) xs + + sc 'x' = FSx + sc 'y' = FSy + sc 'z' = FSz + sc 'w' = FSw + + f 2 = FV2 + f 3 = FV3 + f 4 = FV4 + + synonym 'r' = 'x' + synonym 'g' = 'y' + synonym 'b' = 'z' + synonym 'a' = 'w' + synonym c = c + +parseTermProj = level parseTermAtom $ \t -> + try_ "projection" $ mkProjection t <$ char '.' <*> sepBy1 lowerCase (char '.') + where + mkProjection = foldl $ \exp field -> SBuiltin Fproject `SAppV` litString field `SAppV` exp + +parseTermAtom = + mkLit <$> try_ "literal" parseLit + <|> Wildcard (Wildcard SType) <$ reserved "_" + <|> mkLets <$ reserved "let" <*> parseDefs sLHS <* reserved "in" <*> setR parseTermLam + <|> SGlobal <$> lowerCase + <|> SGlobal <$> upperCase_ + <|> braces (mkRecord <$> commaSep ((,) <$> lowerCase <* symbol ":" <*> setR parseTermLam)) + <|> char '\'' *> ppa switchNamespace + <|> ppa id + where + ppa tick = + brackets ( (setR parseTermLam >>= \e -> + mkDotDot e <$ reservedOp ".." <*> setR parseTermLam + <|> join (foldr (=<<) (pure $ BCons e BNil) <$ reservedOp "|" <*> commaSep (generator <|> letdecl <|> boolExpression)) + <|> mkList . tick <$> asks namespace <*> ((e:) <$> option [] (symbol "," *> commaSep1 (setR parseTermLam))) + ) <|> mkList . tick <$> asks namespace <*> pure []) + <|> parens (SGlobal <$> try_ "opname" (symbols <* lookAhead (symbol ")")) + <|> mkTuple . tick <$> asks namespace <*> commaSep (setR parseTermLam)) + + mkTuple _ [Section e] = e + mkTuple ExpNS [Parens e] = HCons e HNil + mkTuple TypeNS [Parens e] = HList $ BCons e BNil + mkTuple _ [x] = Parens x + mkTuple ExpNS xs = foldr HCons HNil xs + mkTuple TypeNS xs = HList $ foldr BCons BNil xs + + mkList TypeNS [x] = BList x + mkList _ xs = foldr BCons BNil xs + + -- Creates: RecordCons @[("x", _), ("y", _), ("z", _)] (1.0, 2.0, 3.0))) + mkRecord (unzip -> (names, values)) + = SBuiltin FRecordCons `SAppH` foldr BCons BNil (mkRecItem <$> names) `SAppV` foldr HCons HNil values + + mkRecItem l = SBuiltin FRecItem `SAppV` litString l `SAppV` Wildcard SType + + mkDotDot e f = SBuiltin FfromTo `SAppV` e `SAppV` f + + generator, letdecl, boolExpression :: BodyParser (SExp -> ErrorFinder SExp) + generator = do + (dbs, pat) <- try_ "generator" $ longPattern <* reservedOp "<-" + checkPattern dbs + exp <- setR parseTermLam + return $ \e -> do + cf <- runCheck $ compileGuardTree id id (Just $ SIName (sourceInfo pat) "") [(Visible, Wildcard SType)] + $ compilePatts [pat] (noGuards $ deBruijnify dbs e) `mappend` noGuards BNil + return $ SBuiltin FconcatMap `SAppV` cf `SAppV` exp + + letdecl = (return .) . mkLets <$ reserved "let" <*> (runCheck . compileStmt' =<< valueDef) + + boolExpression = (\pred e -> return $ SBuiltin FprimIfThenElse `SAppV` pred `SAppV` e `SAppV` BNil) <$> setR parseTermLam + + +level pr f = pr >>= \t -> option t $ f t + +litString (SIName si n) = SLit si $ LString n + +mkLit n@LInt{} = SBuiltin FfromInt `SAppV` sLit n +mkLit l = sLit l + +-------------------------------------------------------------------------------- pattern parsing + +setR p = appRange $ flip setSI <$> p + +--parsePat... :: BodyParser ParPat +parsePatAnn = patType <$> setR parsePatOp <*> parseType (Just $ Wildcard SType) + where + patType p (Wildcard SType) = p + patType p t = PatTypeSimp p t + +parsePatOp = join $ calculatePatPrecs <$> setR parsePatApp <*> option [] (oper >>= p) + where + oper = addConsInfo $ addFixity colonSymbols + p op = do (exp, op') <- try_ "pattern" $ (,) <$> setR parsePatApp <*> oper + ((op, exp):) <$> p op' + <|> pure . (,) op <$> setR parsePatAnn + + calculatePatPrecs e xs = postponedCheck fst $ calcPrec (\op x y -> PConSimp op [x, y]) (fromJust . nameFixity . fst) e xs + +parsePatApp = + PConSimp <$> addConsInfo upperCase_ <*> many (setR parsePatAt) + <|> parsePatAt + +parsePatAt = concatParPats <$> sepBy1 (setR parsePatAtom) (noSpaceBefore $ reservedOp "@") + where + concatParPats ps = ParPat $ concat [p | ParPat p <- ps] + +parsePatAtom = + mkLit <$> asks namespace <*> try_ "literal" parseLit + <|> flip PConSimp [] <$> addConsInfo upperCase_ + <|> mkPVar <$> patVar + <|> char '\'' *> ppa switchNamespace + <|> ppa id + where + mkLit TypeNS (LInt n) = iterateN (fromIntegral n) cSucc cZero -- todo: elim this alternative + mkLit _ n@LInt{} = litP (SBuiltin FfromInt `SAppV` sLit n) + mkLit _ n = litP (sLit n) + + ppa tick = + brackets (mkListPat . tick <$> asks namespace <*> patlist) + <|> parens (parseViewPat <|> mkTupPat . tick <$> asks namespace <*> patlist) + + mkListPat TypeNS [p] = cList p + mkListPat ns ps = foldr cCons cNil ps + + --mkTupPat :: [Pat] -> Pat + mkTupPat TypeNS [PParens x] = mkTTup [x] + mkTupPat ns [PParens x] = mkTup [x] + mkTupPat _ [x] = PParens x + mkTupPat TypeNS ps = mkTTup ps + mkTupPat ns ps = mkTup ps + + mkTTup = cHList . mkListPat ExpNS + mkTup ps = foldr cHCons cHNil ps + + parseViewPat = ViewPatSimp <$> try_ "view pattern" (setR parseTermOp <* reservedOp "->") <*> setR parsePatAnn + + mkPVar (SIName si "") = PWildcard si + mkPVar s = PVarSimp s + + litP = flip ViewPatSimp cTrue . SAppV (SGlobal $ SIName_ mempty (Just $ Infix 4) "==") + + patlist = commaSep $ setR parsePatAnn + +longPattern = setR parsePatAnn <&> (reverse . getPVars &&& id) + +telescopePat = do + (a, b) <- fmap (reverse . foldMap (getPVars . snd) &&& id) $ many $ uncurry f <$> hiddenTerm (setR parsePatAt) (setR parsePatAt) + checkPattern a + return (a, b) + where + f h (PParens p) = second PParens $ f h p + f h (PatTypeSimp p t) = ((h, t), p) + f h p = ((h, Wildcard SType), p) + +checkPattern :: [SIName] -> BodyParser () +checkPattern ns = tell $ pure $ Left $ + case [reverse ns' | ns'@(_:_:_) <- group . sort . filter (not . null . sName) $ ns] of + [] -> Nothing + xs -> Just $ MultiplePatternVars xs + +postponedCheck pr x = do + tell [Left $ either (\(a, b) -> Just $ OperatorMismatch (pr a) (pr b)) (const Nothing) x] + return $ either (const $ error "impossible @ Parser 725") id x + +type ErrorFinder = BodyParser + +-------------------------------------------------------------------------------- declaration parsing + +parseDef :: BodyParser [PreStmt] +parseDef = + do reserved "data" *> do + x <- typeNS upperCase + (npsd, ts) <- telescope (Just SType) + t <- deBruijnify npsd <$> parseType (Just SType) + adf <- addForalls_ npsd + let mkConTy mk (nps', ts') = + ( if mk then Just $ reverse nps' else Nothing + , deBruijnify npsd $ foldr (uncurry SPi) (foldl SAppV (SGlobal x) $ SGlobal <$> reverse npsd) ts' + ) + (af, cs) <- option (True, []) $ + (,) True . map (second $ (,) Nothing) . concat <$ reserved "where" <*> identation True (typedIds id npsd) + <|> (,) False <$ reservedOp "=" <*> + sepBy1 ((,) <$> (addFixity' upperCase <|> parens (addFixity colonSymbols)) + <*> (mkConTy True <$> braces telescopeDataFields <|> mkConTy False <$> telescope Nothing) + ) + (reservedOp "|") + mkData x ts t $ second (second $ if af then adf else id) <$> cs + <|> do reserved "class" *> do + x <- typeNS upperCase + (nps, ts) <- telescope (Just SType) + cs <- option [] $ concat <$ reserved "where" <*> identation True (typedIds id nps) + return $ pure $ Class x (map snd ts) cs + <|> do reserved "instance" *> do + typeNS $ do + constraints <- option [] $ try_ "constraint" $ getTTuple <$> setR parseTermOp <* reservedOp "=>" + x <- upperCase + (nps, args) <- telescopePat + cs <- expNS $ option [] $ reserved "where" *> identation False ({-deBruijnify nps <$> -} funAltDef (Just lhsOperator) varId) + pure . Instance x ({-todo-}map snd args) (deBruijnify nps <$> constraints) <$> runCheck (compileStmt' cs) + <|> do reserved "type" *> do + typeNS $ do + reserved "family" *> do + x <- upperCase + (nps, ts) <- telescope (Just SType) + t <- deBruijnify nps <$> parseType (Just SType) + option {-open type family-}[TypeFamily x $ UncurryS ts t] $ do + cs <- (reserved "where" >>) $ identation True $ funAltDef Nothing $ mfilter (== x) upperCase + -- closed type family desugared here + runCheck $ fmap Stmt <$> compileStmt SLHS (compileGuardTrees id . const Nothing) [TypeAnn x $ UncurryS ts t] cs + <|> pure <$ reserved "instance" <*> funAltDef Nothing upperCase + <|> do x <- upperCase + (nps, ts) <- telescope $ Just (Wildcard SType) + rhs <- deBruijnify nps <$ reservedOp "=" <*> setR parseTermLam + runCheck $ fmap Stmt <$> compileStmt SLHS (compileGuardTrees id . const Nothing) + [{-TypeAnn x $ UncurryS ts $ SType-}{-todo-}] + [funAlt' x ts (map PVarSimp $ reverse nps) $ noGuards rhs] + <|> do try_ "typed ident" $ map (uncurry TypeAnn) <$> typedIds addForalls' [] + <|> fmap . (Stmt .) . flip PrecDef <$> parseFixity <*> commaSep1 rhsOperator + <|> pure <$> funAltDef (Just lhsOperator) varId + <|> valueDef + where + telescopeDataFields :: BodyParser ([SIName], [(Visibility, SExp)]) + telescopeDataFields = mkTelescope <$> commaSep ((,) Visible <$> ((,) <$> lowerCase <*> parseType Nothing)) + + mkData x ts t cs + = (Stmt (Data x ts t (second snd <$> cs)):) . concat <$> traverse mkProj (nub $ concat [fs | (_, (Just fs, _)) <- cs]) + where + mkProj fn = sequence + [ do + cn' <- addConsInfo $ pure cn + + return $ funAlt' fn [(Visible, Wildcard SType)] + [PConSimp cn' [if i == j then PVarSimp (dummyName "x") else PWildcard mempty | j <- [0..length fs-1]]] + $ noGuards $ sVar "proj" 0 + | (cn, (Just fs, _)) <- cs, (i, fn') <- zip [0..] fs, fn' == fn + ] + +parseRHS :: String -> BodyParser GuardTrees +parseRHS tok = do + mkGuards <$> some (reservedOp "|" *> guard) <*> option [] (reserved "where" *> parseDefs sLHS) + <|> do + rhs <- reservedOp tok *> setR parseTermLam + f <- option id $ mkLets <$ reserved "where" <*> parseDefs sLHS + noGuards <$> trackSI (pure $ f rhs) + where + guard = do + (nps, ps) <- mkTelescope' <$> commaSep1 guardPiece <* reservedOp tok + e <- trackSI $ setR parseTermLam + return (ps, deBruijnify nps e) + + guardPiece = getVars <$> option cTrue (try_ "pattern guard" $ setR parsePatOp <* reservedOp "<-") <*> setR parseTermOp + where + getVars p e = (reverse $ getPVars p, (p, e)) + + mkGuards gs wh = mkLets_ lLet wh $ mconcat [foldr (uncurry guardNode') (noGuards e) ge | (ge, e) <- gs] + +parseDefs lhs = identation True parseDef >>= runCheck . compileStmt'_ lhs SRHS SRHS . concat + +funAltDef parseOpName parseName = do + (n, (fee, tss)) <- + case parseOpName of + Nothing -> mzero + Just opName -> try_ "operator definition" $ do + (e', a1) <- longPattern + n <- opName + (e'', a2) <- longPattern <* lookAhead (reservedOp "=" <|> reservedOp "|") + let fee = e'' <> e' + checkPattern fee + return (n, (fee, (,) (Visible, Wildcard SType) <$> [a1, deBruijnify e' a2])) + <|> do try_ "lhs" $ (,) <$> parseName <*> telescopePat <* lookAhead (reservedOp "=" <|> reservedOp "|") + funAlt n tss . deBruijnify fee <$> parseRHS "=" + +valueDef :: BodyParser [PreStmt] +valueDef = do + (dns, p) <- try_ "pattern" $ longPattern <* reservedOp "=" + checkPattern dns + runCheck . desugarValueDef p =<< setR parseTermLam + +-------------------------------------------------------------------------------- modules + +parseExport :: HeaderParser Export +parseExport = + ExportModule <$ reserved "module" <*> moduleName + <|> ExportId <$> varId + +importlist = parens $ commaSep upperLower + +parseExtensions :: HeaderParser [Extension] +parseExtensions + = try_ "pragma" (symbol "{-#") *> symbol "LANGUAGE" *> commaSep (lexeme ext) <* symbolWithoutSpace "#-}" <* simpleSpace + where + ext = do + s <- some $ satisfy isAlphaNum + maybe + (fail $ "language extension expected instead of " ++ s) + return + (Map.lookup s extensionMap) + +type Module = Module_ DefParser + +type DefParser = DesugarInfo -> Either ParseError ([Stmt], [PostponedCheck]) + +type HeaderParser = Parse () () + +parseModule :: HeaderParser Module +parseModule = do + exts <- concat <$> many parseExtensions + whiteSpace + header <- optional $ do + modn <- reserved "module" *> moduleName + exps <- optional (parens $ commaSep parseExport) <* reserved "where" + return (modn, exps) + let mkIDef _ n i h _ = (n, f i h) + where + f Nothing Nothing = ImportAllBut [] + f (Just h) Nothing = ImportAllBut h + f Nothing (Just i) = ImportJust i + idefs <- many $ + mkIDef <$ reserved "import" + <*> optional (reserved "qualified") + <*> moduleName + <*> optional (reserved "hiding" *> importlist) + <*> optional importlist + <*> optional (reserved "as" *> moduleName) + (env, st) <- getParseState + return Module + { extensions = exts + , moduleImports = [(SIName mempty "Prelude", ImportAllBut []) | NoImplicitPrelude `notElem` exts] ++ idefs + , moduleExports = join $ snd <$> header + , definitions = \ge -> runParse (parseDefs SLHS <* eof) (env { desugarInfo = ge }, st) + } + +parseLC :: FileInfo -> Either ParseError Module +parseLC fi + = fmap fst $ runParse parseModule $ parseState fi () + +runDefParser :: (MonadFix m, MonadError LCParseError m) => DesugarInfo -> DefParser -> m ([Stmt], [ParseWarning], DesugarInfo) +runDefParser ds_ dp = do + + (defs, dns, ds) <- mfix $ \ ~(_, _, ds) -> do + let x = dp (ds <> ds_) + (defs, dns) <- either (throwError . ParseError) return x + return (defs, dns, mkDesugarInfo defs) + + mapM_ throwError [x | Left (Just x) <- dns] + + let ism = Set.fromList [is | Right (Reachable is) <- dns] + f (TrackedCode is) | is `Set.notMember` ism = Just $ Unreachable is + f (Uncovered' si x) | not $ null $ filter (not . null . fst) x = Just $ Uncovered si x + f _ = Nothing + + return (concatMap desugarMutual $ sortDefs defs, catMaybes [f w | Right w <- dns], ds) diff --git a/src/LambdaCube/Compiler/Patterns.hs b/src/LambdaCube/Compiler/Patterns.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/Patterns.hs @@ -0,0 +1,346 @@ +-- Pattern match compilation +-- +-- overview: +-- https://rawgit.com/BP-HUG/presentations/master/2016_april/pattern-match-compilation/patternMatchComp.html + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LambdaCube.Compiler.Patterns where + +import Data.Monoid +import Data.Maybe +import qualified Data.Set as Set +import Control.Monad.Writer +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (braces, parens) +import LambdaCube.Compiler.DesugaredSource + +--------------------------------- + +data ParseCheck + = TrackedCode Range + | Reachable Range + | Uncovered' SIName [PatList] + +type PatList = ([ParPat_ ()], [(ParPat_ (), SExp)]) + +type ConsInfo = Either ((SName{-case eliminator name-}, Int{-num of indices-}), [(SIName, Int)]{-constructors with arities-}) + Int{-arity-} + +-------------------------------------------------------------------------------- pattern representation + +type Pat = Pat_ ConsInfo + +data Pat_ c + = PVar SIName + | PCon_ SI (SIName, c) [ParPat_ c] + | ViewPat_ SI SExp (ParPat_ c) + | PatType_ SI (ParPat_ c) SExp + +type ParPat = ParPat_ ConsInfo + +-- parallel patterns like v@(f -> [])@(Just x) +data ParPat_ c = ParPat_ SI [Pat_ c] + +pattern ParPat ps <- ParPat_ _ ps + where ParPat ps = ParPat_ (foldMap sourceInfo ps) ps + +instance PShow (Pat_ a) where + pShow = \case + PVar sn -> pShow sn + PCon (sn, _) ps -> foldl DApp (pShow sn) (pShow <$> ps) + ViewPat e p -> DOp "->" (Infix (-1)) (pShow e) (pShow p) + PatType p t -> DAnn (pShow p) (pShow t) + +instance PShow (ParPat_ a) where + pShow = \case + ParPat [] -> text "_" + ParPat ps -> foldr1 (DOp "@" (InfixR 11)) $ pShow <$> ps + + + +pattern PWildcard si = ParPat_ si [] +pattern PCon n pp <- PCon_ _ n pp + where PCon n pp = PCon_ (sourceInfo (fst n) <> sourceInfo pp) n pp +pattern ViewPat e pp <- ViewPat_ _ e pp + where ViewPat e pp = ViewPat_ (sourceInfo e <> sourceInfo pp) e pp +pattern PatType pp e <- PatType_ _ pp e + where PatType pp e = PatType_ (sourceInfo e <> sourceInfo pp) pp e +--pattern SimpPats ps <- (traverse simpleParPat -> Just ps) +-- where SimpPats ps = ParPat . (:[]) <$> ps + +--simpleParPat (ParPat [p]) = Just p +--simpleParPat _ = Nothing + +pattern PVarSimp n = ParPat [PVar n] +pattern PConSimp n ps = ParPat [PCon n ps] +--pattern PConSimp n ps = PCon n (SimpPats ps) +pattern ViewPatSimp e p = ParPat [ViewPat e p] +pattern PatTypeSimp p t = ParPat [PatType p t] + +pBuiltin n ci ps = PConSimp (Tag n, left (second $ map $ first Tag) ci) ps + +cTrue = pBuiltin FTrue (Left ((CaseName "'Bool", 0), [(FFalse, 0), (FTrue, 0)])) [] +cZero = pBuiltin FZero (Left ((CaseName "'Nat", 0), [(FZero, 0), (FSucc, 1)])) [] +cNil = pBuiltin FNil (Left ((CaseName "'List", 0), [(FNil, 0), (FCons, 2)])) [] +cHNil = pBuiltin FHNil (Left (("hlistNilCase", -1), [(FHNil, 0)])) [] +cList a = pBuiltin F'List (Right 1) [a] +cHList a = pBuiltin F'HList (Right 1) [a] +cSucc a = pBuiltin FSucc (Left ((CaseName "'Nat", 0), [(FZero, 0), (FSucc, 1)])) [a] +cCons a b = pBuiltin FCons (Left ((CaseName "'List", 0), [(FNil, 0), (FCons, 2)])) [a, b] +cHCons a b = pBuiltin FHCons (Left (("hlistConsCase", -1), [(FHCons, 2)])) [a, b] + +pattern PParens p = ViewPatSimp (SBuiltin Fparens) p + +mapP :: (Int -> SExp -> SExp) -> Int -> Pat -> Pat +mapP f i = \case + PVar n -> PVar n + PCon_ si n ps -> PCon_ si n (upPats (mapPP f) i ps) + ViewPat_ si e p -> ViewPat_ si (f i e) (mapPP f i p) + PatType_ si p t -> PatType_ si (mapPP f i p) (f i t) + +mapPP f i = \case + ParPat_ si ps -> ParPat_ si $ upPats (mapP f) i ps + +upPats g k [] = [] +upPats g k (p: ps) = g k p: upPats g (k + patVars p) ps + +instance Rearrange Pat where + rearrange k f = mapP (`rearrange` f) k + +instance Rearrange ParPat where + rearrange k f = mapPP (`rearrange` f) k + +instance DeBruijnify SIName ParPat where + deBruijnify_ l ns = mapPP (`deBruijnify_` ns) l + +-- pattern variables +class PatVars a where getPVars :: a -> [SIName] + +instance PatVars Pat + where + getPVars = \case + PVar n -> [n] + PCon _ ps -> foldMap getPVars ps + ViewPat e p -> getPVars p + PatType p t -> getPVars p + +instance PatVars ParPat where getPVars (ParPat ps) = foldMap getPVars ps + +instance PatVars a => PatVars [a] where getPVars = foldMap getPVars + +-- number of pattern variables +patVars :: PatVars a => a -> Int +patVars = length . getPVars + +instance SourceInfo (ParPat_ c) where + sourceInfo (ParPat_ si _) = si + +instance SetSourceInfo (ParPat_ c) where + setSI si (ParPat_ _ ps) = ParPat_ si ps + +instance SourceInfo (Pat_ c) where + sourceInfo = \case + PVar sn -> sourceInfo sn + PCon_ si _ _ -> si + ViewPat_ si _ _ -> si + PatType_ si _ _ -> si + +instance SetSourceInfo (Pat_ c) where + setSI si = \case + PVar sn -> PVar $ setSI si sn + PCon_ _ a b -> PCon_ si a b + ViewPat_ _ a b -> ViewPat_ si a b + PatType_ _ a b -> PatType_ si a b + +-------------------------------------------------------------------------------- pattern match compilation + +-- pattern match compilation monad +type PMC = Writer ([CasePath], [Range]) + +type CasePath = [Maybe (SIName, Int, SExp)] + +runPMC :: MonadWriter [ParseCheck] m => Maybe SIName -> [(Visibility, SExp)] -> PMC a -> m a +runPMC si vt m = do + tell $ Reachable <$> rs + case si of + Nothing -> return () + Just si -> tell [Uncovered' si [mkPatt_ (zip [0 :: Int ..] $ reverse p) $ reverse [0.. length vt - 1] | Just p <- sequence <$> ps]] + return a + where + (a, (ps, rs)) = runWriter m + + mkPatt_ ps_ is = (ps, mkGuards 0 ps_) + where + (mconcat -> qs, ps) = unzip $ map (mkPatt 0 ps_) is + + mkGuards k [] = [] + mkGuards k ((q, (cn, n, e)): ps) = [(PConSimp (cn, ()) $ replicate n $ PWildcard mempty, e) | q `Set.notMember` qs] ++ mkGuards (k + n) ps + + mkPatt k ((q, (cn, n, SVar _ j)): ps) i | j == (i + k) + = (Set.singleton q <>) . mconcat *** PConSimp (cn, ()) $ unzip [mkPatt 0 ps l | l <- [n-1, n-2..0]] + mkPatt k ((q, (cn, n, _)): ps) i = mkPatt (k + n) ps i + mkPatt k [] i = (mempty, PWildcard mempty) +-- mkPatt k ps' i = error $ "mkPatt " ++ show i_ ++ ": " ++ maybe "" showSI si ++ "\n" ++ show ps' ++ "\n" ++ show ps_ + +data Lets a + = LLet SIName SExp (Lets a) + | LTypeAnn SExp (Lets a) -- TODO: eliminate if not used + | In a + +lLet sn (SVar sn' i) l = rSubst 0 i l +lLet sn e l = LLet sn e l + +foldLets f = \case + In e -> f e + LLet sn e x -> foldLets f x + LTypeAnn e x -> foldLets f x + +mapLets f h l = \case + In e -> In $ h l e + LLet sn e x -> LLet sn (f l e) $ mapLets f h (l+1) x + LTypeAnn e x -> LTypeAnn (f l e) $ mapLets f h l x + +instance Rearrange a => Rearrange (Lets a) where + rearrange l f = mapLets (`rearrange` f) (`rearrange` f) l + +instance DeBruijnify SIName a => DeBruijnify SIName (Lets a) where + deBruijnify_ l ns = mapLets (`deBruijnify_` ns) (`deBruijnify_` ns) l + +data GuardTree + = GuardNode SExp (SIName, ConsInfo) [SIName] GuardTrees GuardTrees + | GTSuccess SExp + | GTFailure + +instance DeBruijnify SIName GuardTree where + deBruijnify_ l ns = mapGT (`deBruijnify_` ns) (`deBruijnify_` ns) l + +type GuardTrees = Lets GuardTree + +instance Monoid GuardTrees where + mempty = In GTFailure + LLet sn e x `mappend` y = LLet sn e $ x `mappend` rUp 1 0 y + LTypeAnn t x `mappend` y = LTypeAnn t $ x `mappend` y + In (GuardNode e n ps t ts) `mappend` y = In $ GuardNode e n ps t (ts `mappend` y) + In GTFailure `mappend` y = y + x@(In GTSuccess{}) `mappend` _ = x + +noGuards = In . GTSuccess + +mapGT :: (Int -> ParPat -> ParPat) -> (Int -> SExp -> SExp) -> Int -> GuardTree -> GuardTree +mapGT f h k = \case + GuardNode e c pps gt el -> GuardNode (h k e) c pps (mapGTs f h (k + length pps) gt) (mapGTs f h k el) + GTSuccess e -> GTSuccess $ h k e + GTFailure -> GTFailure + +mapGTs f h = mapLets h (mapGT f h) +{- +foldGT f = \case + GuardNode e c pps gt el -> GuardNode (h k e) c pps (mapGTs f h (k + length pps) gt) (mapGTs f h k el) + GTSuccess e -> f e + GTFailure -> mempty +-} +instance Rearrange GuardTree where + rearrange l f = mapGT (`rearrange` f) (`rearrange` f) l + +pattern Otherwise = SBuiltin Fotherwise + +guardNode :: Pat -> SExp -> GuardTrees -> GuardTrees +guardNode (PCon (sName -> "True", _) []) Otherwise gt = gt +guardNode (PCon (sName -> "False", _) []) Otherwise gt = In GTFailure +guardNode (PVar sn) e gt = lLet sn e gt +guardNode (ViewPat f p) e gt = guardNode' p (f `SAppV` e) gt +guardNode (PatType p t) e gt = guardNode' p (SAnn e t) gt +guardNode (PCon sn ps) e gt = In $ GuardNode e sn (replicate n $ dummyName "gn") (buildNode guardNode' n ps [n-1, n-2..0] gt) mempty + where + n = length ps + +guardNode' (PParens p) e gt = guardNode' p e gt +guardNode' (ParPat_ si ps) e gt = case ps of + [] -> gt + [p] -> guardNode p e gt + ps -> lLet (SIName si "gtc") e $ buildNode guardNode 1 ps [0..] gt + +buildNode guardNode n ps is gt + = foldr f (rUp n (patVars ps) gt) $ zip3 ps is $ scanl (+) 0 $ map patVars ps + where + f (p, i, d) = guardNode (rUp n d p) (sVar "gn" $ i + d) + +compilePatts :: [ParPat] -> GuardTrees -> GuardTrees +compilePatts ps = buildNode guardNode' n ps [n-1, n-2..0] + where + n = length ps + +compileGuardTree :: MonadWriter [ParseCheck] m => (SExp -> SExp) -> (SExp -> SExp) -> Maybe SIName -> [(Visibility, SExp)] -> GuardTrees -> m SExp +compileGuardTree ulend lend si vt = fmap (\e -> foldr (uncurry SLam) e vt) . runPMC si vt . guardTreeToCases [] + where + guardTreeToCases :: CasePath -> GuardTrees -> PMC SExp + guardTreeToCases path = \case + LLet sn e g -> SLet sn e <$> guardTreeToCases (Nothing: path){-TODO-} g + LTypeAnn t g -> SAnn <$> guardTreeToCases (Nothing: path){-TODO-} g <*> pure t + In GTFailure -> do + tell ([path], mempty) + return $ ulend $ SBuiltin Fundefined + In (GTSuccess e) -> do + tell $ (,) mempty $ maybeToList $ getRange $ sourceInfo e + return $ lend e + ts@(In (GuardNode f (s, cn) _ _ _)) -> case cn of + Left ((casename, inum), cns) -> do + cf <- sequence [ iterateN n SLamV <$> guardTreeToCases (Just (cn, n, f): path) (filterGuardTree (up n f) cn 0 n $ rUp n 0 ts) + | (cn, n) <- cns ] + return $ + foldl SAppV + (SGlobal (SIName mempty casename) `SAppV` iterateN (1 + inum) SLamV (Wildcard SType)) + cf + `SAppV` f + Right n -> do + g1 <- guardTreeToCases (Nothing: path){-TODO-} $ filterGuardTree (up n f) s 0 n $ rUp n 0 ts + g2 <- guardTreeToCases (Nothing: path){-TODO-} $ filterGuardTree' f s ts + return $ SGlobal (SIName mempty $ MatchName $ sName s) + `SAppV` SLamV (Wildcard SType) + `SAppV` iterateN n SLamV g1 + `SAppV` f + `SAppV` g2 + + filterGuardTree' :: SExp -> SIName{-constr.-} -> GuardTrees -> GuardTrees + filterGuardTree' f s = \case + LLet sn e gt -> LLet sn e $ filterGuardTree' (up 1 f) s gt + LTypeAnn e gt -> LTypeAnn e $ filterGuardTree' f s gt + In (GuardNode f' s' ps gs (filterGuardTree' f s -> el)) + | f /= f' || s /= fst s' -> In $ GuardNode f' s' ps (filterGuardTree' (up (length ps) f) s gs) el + | otherwise -> el + In x -> In x + + filterGuardTree :: SExp -> SIName{-constr.-} -> Int -> Int{-number of constr. params-} -> GuardTrees -> GuardTrees + filterGuardTree f s k ns = \case + LLet sn e gt -> LLet sn e $ filterGuardTree (up 1 f) s (k + 1) ns gt + LTypeAnn e gt -> LTypeAnn e $ filterGuardTree f s k ns gt + In (GuardNode f' s' ps gs (filterGuardTree f s k ns -> el)) + | f /= f' -> In $ GuardNode f' s' ps (filterGuardTree (up su f) s (su + k) ns gs) el + | s == fst s' -> filterGuardTree f s k ns $ foldr (rSubst 0) gs (replicate su $ k+ns-1) <> el + | otherwise -> el + where + su = length ps + In x -> In x + +compileGuardTrees ulend si vt = compileGuardTree ulend SRHS si vt . mconcat + +compileGuardTrees' si vt = fmap (foldr1 $ SAppV2 $ SBuiltin FparEval `SAppV` Wildcard SType) . mapM (compileGuardTrees id Nothing vt . (:[])) + +compileCase x cs + = (`SAppV` x) <$> compileGuardTree id id (Just $ SIName (sourceInfo x) "") [(Visible, Wildcard SType)] (mconcat [compilePatts [p] e | (p, e) <- cs]) + +patLam :: MonadWriter [ParseCheck] m => (SExp -> SExp) -> (Visibility, SExp) -> ParPat -> SExp -> m SExp +patLam f vt p e = compileGuardTree f f (Just $ SIName (sourceInfo p) "") [vt] (compilePatts [p] $ noGuards e) + 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 @@ -4,149 +4,441 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} module LambdaCube.Compiler.Pretty ( module LambdaCube.Compiler.Pretty - , Doc - , (<+>), (), (<$$>) - , hsep, hcat, vcat - , punctuate - , tupled, braces, parens - , text - , nest ) where +import Data.Maybe import Data.String -import Data.Set (Set) +import Data.Char +import Data.Monoid import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Control.Monad.Except +import qualified Data.Map.Strict as Map +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.State +import Control.Arrow hiding ((<+>)) import Debug.Trace -import Text.PrettyPrint.Leijen +import qualified Text.PrettyPrint.ANSI.Leijen as P --------------------------------------------------------------------------------- +import LambdaCube.Compiler.Utils -instance IsString Doc where fromString = text +-------------------------------------------------------------------------------- fixity +data Fixity + = Infix !Int + | InfixL !Int + | InfixR !Int + deriving (Eq) + +instance PShow Fixity where + pShow = \case + Infix i -> "infix" <+> pShow i + InfixL i -> "infixl" <+> pShow i + InfixR i -> "infixr" <+> pShow i + +precedence, leftPrecedence, rightPrecedence :: Fixity -> Int + +precedence = \case + Infix i -> i + InfixR i -> i + InfixL i -> i + +leftPrecedence (InfixL i) = i +leftPrecedence f = precedence f + 1 + +rightPrecedence (InfixR i) = i +rightPrecedence f = precedence f + 1 + +defaultFixity :: Maybe Fixity -> Fixity +defaultFixity = fromMaybe (InfixL 9) + +-------------------------------------------------------------------------------- doc data type + +data Doc + = forall f . Traversable f => DDocOp (f P.Doc -> P.Doc) (f Doc) + | DFormat (P.Doc -> P.Doc) Doc + | DTypeNamespace Bool Doc + + | DAtom DocAtom + | DInfix Fixity Doc DocAtom Doc + | DPreOp Int DocAtom Doc + + | DFreshName (Maybe String){-used-} Doc + | DVar Int + | DUp Int Doc + | DResetFreshNames Doc + + | DExpand Doc Doc + +data DocAtom + = SimpleAtom String + | ComplexAtom String Int Doc DocAtom + +mapDocAtom f (SimpleAtom s) = SimpleAtom s +mapDocAtom f (ComplexAtom s i d a) = ComplexAtom s i (f s i d) $ mapDocAtom f a + +instance IsString Doc where + fromString = text + +text = DText +pattern DText s = DAtom (SimpleAtom s) + instance Monoid Doc where - mempty = empty - mappend = (<>) + mempty = text "" + mappend = dTwo mappend -class PShow a where - pShowPrec :: Int -> a -> Doc +instance Show Doc where + show = ($ "") . P.displayS . P.renderPretty 0.4 200 . renderDoc -pShow = pShowPrec (-2) -ppShow = show . pShow +plainShow :: PShow a => a -> String +plainShow = ($ "") . P.displayS . P.renderPretty 0.6 150 . P.plain . renderDoc . pShow -ppShow' = show +simpleShow :: PShow a => a -> String +simpleShow = ($ "") . P.displayS . P.renderPretty 0.4 200 . P.plain . renderDoc . pShow +mkFreshName :: MonadState (Map.Map String Int, [String]) m => String -> m String +mkFreshName n = state $ addIndex n + where + addIndex "" (m, (n:ns)) = add n (m, ns) + addIndex n (m, ns) = add n (m, ns) -{- -prec 0: no outer parens needed -prec 10: argument of a function + add n (m, ns) = case Map.lookup n m of + Just i -> (n ++ (toSubscript <$> show (i+1)), (Map.insert n (i+1) m, ns)) + Nothing -> (n, (Map.insert n 0 m, ns)) +renderDoc :: Doc -> P.Doc +renderDoc + = render + . addPar (-10, -10) + . namespace False + . flip runReader freeNames + . flip evalStateT freshNames + . showVars + . expand True + where + freshNames = (mempty, cycle $ (:[]) <$> ['a'..'z']) + freeNames = map ('_':) $ flip (:) <$> iterate ('\'':) "" <*> ['a'..'z'] -f x (g y) + noexpand = expand False + expand full = \case + DExpand short long -> expand full $ if full then long else short + DFormat c x -> DFormat c $ expand full x + DTypeNamespace c x -> DTypeNamespace c $ expand full x + DDocOp x d -> DDocOp x $ expand full <$> d + DAtom s -> DAtom $ mapDocAtom (\_ _ -> noexpand) s + DInfix pr x op y -> DInfix pr (noexpand x) (mapDocAtom (\_ _ -> noexpand) op) (noexpand y) + DPreOp pr op y -> DPreOp pr (mapDocAtom (\_ _ -> noexpand) op) (noexpand y) + DVar i -> DVar i + DFreshName b x -> (if full then DResetFreshNames else id) $ DFreshName b $ noexpand x + DResetFreshNames x -> DResetFreshNames $ expand full x + DUp i x -> DUp i $ noexpand x + showVars = \case + DAtom s -> DAtom <$> showVarA s + DFormat c x -> DFormat c <$> showVars x + DTypeNamespace c x -> DTypeNamespace c <$> showVars x + DDocOp x d -> DDocOp x <$> traverse showVars d + DInfix pr x op y -> DInfix pr <$> showVars x <*> showVarA op <*> showVars y + DPreOp pr op y -> DPreOp pr <$> showVarA op <*> showVars y + DVar i -> asks $ text . (!! i) + DFreshName (Just n) x -> mkFreshName n >>= \n -> local (n:) (showVars x) + DFreshName Nothing x -> local ("_":) $ showVars x + DResetFreshNames x -> do + st <- get + put freshNames + local (const freeNames) (showVars x) <* put st + DUp i x -> local (dropIndex i) $ showVars x + where + showVarA (SimpleAtom s) = pure $ SimpleAtom s + showVarA (ComplexAtom s i d a) = ComplexAtom s i <$> showVars d <*> showVarA a --} + getTup (DText "HCons" `DApp` x `DApp` (getTup -> Just xs)) = Just $ x: xs + getTup (DText "HNil") = Just [] + getTup _ = Nothing --------------------------------------------------------------------------------- + getList (DOp0 ":" _ `DApp` x `DApp` (getList -> Just xs)) = Just $ x: xs + getList (DText "Nil") = Just [] + getList _ = Nothing -pParens p x - | p = tupled [x] - | otherwise = x + shTick True = DPreOp 20 (SimpleAtom "'") + shTick False = id -pOp i j k sep p a b = pParens (p >= i) $ pShowPrec j a <+> sep <+> pShowPrec k b -pOp' i j k sep p a b = pParens (p >= i) $ pShowPrec j a sep <+> pShowPrec k b + namespace :: Bool -> Doc -> Doc + namespace tn x = case x of + (getTup -> Just xs) -> shTick tn $ namespace tn $ shTuple xs + (getList -> Just xs) -> shTick tn $ namespace tn $ shList xs + DText "'HList" `DApp` (getList -> Just xs) -> shTick (not tn) $ namespace tn $ shTuple xs + DAtom x -> DAtom $ namespaceA x + DText "'List" `DApp` x -> namespace tn $ DBracket x + DInfix pr' x op y -> DInfix pr' (namespace tn x) (namespaceA op) (namespace tn y) + DPreOp pr' op y -> DPreOp pr' (namespaceA op) (namespace tn y) + DFormat c x -> DFormat c $ namespace tn x + DTypeNamespace c x -> namespace c x + DDocOp x d -> DDocOp x $ namespace tn <$> d + where + namespaceA (SimpleAtom s) = SimpleAtom $ switch tn s + namespaceA (ComplexAtom s i d a) = ComplexAtom s i (namespace tn d) $ namespaceA a -pInfixl i = pOp i (i-1) i -pInfixr i = pOp i i (i-1) -pInfixr' i = pOp' i i (i-1) -pInfix i = pOp i i i + switch True ('`': '\'': cs@(c: _)) | isUpper c = '`': cs + switch True ('\'': cs@(c: _)) | isUpper c {- && last cs /= '\'' -} = cs + switch True "Type" = "Type" -- TODO: remove + switch True cs@(c:_) | isUpper c = '\'': cs + switch _ x = x -pTyApp = pInfixl 10 "@" -pApps p x [] = pShowPrec p x -pApps p x xs = pParens (p > 9) $ hsep $ pShowPrec 9 x: map (pShowPrec 10) xs -pApp p a b = pApps p a [b] + addPar :: (Int, Int) -> Doc -> Doc + addPar pr@(prl, prr) x = case x of + DAtom x -> DAtom $ addParA x + DOp0 s f -> DParen $ DOp0 s f + DOp0 s f `DApp` x `DApp` y -> addPar pr $ DOp (addBackquotes s) f x y + DInfix pr' x op y + | precedence pr' < prl || precedence pr' < prr + -> DParen $ DInfix pr' (addPar (-20, leftPrecedence pr') x) (addParA op) (addPar (rightPrecedence pr', -20) y) + | otherwise -> DInfix pr' (addPar (prl, leftPrecedence pr') x) (addParA op) (addPar (rightPrecedence pr', prr) y) + DPreOp pr' op y + | pr' < prr -> DParen $ DPreOp pr' (addParA op) (addPar (pr', -20) y) + | otherwise -> DPreOp pr' (addParA op) (addPar (pr', prr) y) + DFormat c x -> DFormat c $ addPar pr x + DTypeNamespace c x -> DTypeNamespace c $ addPar pr x + DDocOp x d -> DDocOp x $ addPar (-10, -10) <$> d + where + addParA (SimpleAtom s) = SimpleAtom s + addParA (ComplexAtom s i d a) = ComplexAtom s i (addPar (i, i) d) $ addParA a -showRecord = braces . hsep . punctuate (pShow ',') . map (\(a, b) -> pShow a <> ":" <+> pShow b) + addBackquotes "EqCTt" = "~" + addBackquotes s@(c:_) | isAlpha c || c == '_' || c == '\'' = '`': s ++ "`" + addBackquotes s = s --------------------------------------------------------------------------------- + getApps (DApp (getApps -> (n, xs)) x) = (n, x: xs) + getApps x = (x, []) -instance PShow Bool where - pShowPrec p b = if b then "True" else "False" + getSemis (DSemi x (getSemis -> (xs, n))) = (x: xs, n) + getSemis x = ([], x) -instance (PShow a, PShow b) => PShow (a, b) where - pShowPrec p (a, b) = tupled [pShow a, pShow b] + getCommas (DComma x (getCommas -> xs)) = x: xs + getCommas x = [x] -instance (PShow a, PShow b, PShow c) => PShow (a, b, c) where - pShowPrec p (a, b, c) = tupled [pShow a, pShow b, pShow c] + render :: Doc -> P.Doc + render = snd . render' + where + render' = \case + DAtom x -> renderA x + DFormat c x -> second c $ render' x + DDocOp f d -> (('\0', '\0'), f $ render <$> d) + DPreOp _ op y -> renderA' op <++> render' y + DSep (InfixR 11) a b -> gr $ render' a <+++> render' b + x@DApp{} -> case getApps x of + (n, reverse -> xs) -> ((\xs -> (fst $ head xs, snd $ last xs)) *** P.nest 2 . P.sep) (unzip $ render' n: (render' <$> xs)) + x@DComma{} -> case getCommas x of + x: xs -> ((\xs -> (fst $ head xs, snd $ last xs)) *** P.cat) (unzip $ render' x: (second ("," P.<+>) . render' <$> xs)) + x@DSemi{} -> case getSemis x of + (xs, n) -> ((\xs -> (fst $ head xs, snd $ last xs)) *** P.sep) (unzip $ (second (<> ";") . render' <$> xs) ++ [render' n]) + DInfix _ x op y -> gr $ render' x <+++> renderA op <++> render' y -instance PShow a => PShow [a] where - pShowPrec p = brackets . sep . punctuate comma . map pShow + renderA' (SimpleAtom s) = rtext s + renderA' x = gr $ renderA'' x -instance PShow a => PShow (Maybe a) where - pShowPrec p = \case - Nothing -> "Nothing" - Just x -> "Just" <+> pShow x + renderA'' (SimpleAtom s) = rtext s + renderA'' (ComplexAtom s _ d a) = rtext s <+++> render' d <+++> renderA'' a -instance PShow a => PShow (Set a) where - pShowPrec p = pShowPrec p . Set.toList + renderA (SimpleAtom s) = rtext s + renderA (ComplexAtom s _ d a) = rtext s <++> render' d <++> renderA a -instance (PShow s, PShow a) => PShow (Map s a) where - pShowPrec p = braces . vcat . map (\(k, t) -> pShow k <> colon <+> pShow t) . Map.toList + gr = second (P.nest 2 . P.group) -instance (PShow a, PShow b) => PShow (Either a b) where - pShowPrec p = either (("Left" <+>) . pShow) (("Right" <+>) . pShow) + rtext "" = (('\0', '\0'), mempty) + rtext s@(h:_) = ((h, last s), P.text s) -instance PShow Doc where - pShowPrec p x = x + ((lx, rx), x) <++> ((ly, ry), y) = ((lx, ry), z) + where + z | sep rx ly = x P.<+> y + | otherwise = x <> y -instance PShow Int where pShowPrec _ = int -instance PShow Integer where pShowPrec _ = integer -instance PShow Double where pShowPrec _ = double -instance PShow Char where pShowPrec _ = char -instance PShow () where pShowPrec _ _ = "()" + ((lx, rx), x) <+++> ((ly, ry), y) = ((lx, ry), z) + where + z | sep rx ly = x <> P.line <> y + | otherwise = x <> y + sep x y + | x == '\0' || y == '\0' = False + | isSpace x || isSpace y = False + | y == ',' = False + | x == ',' = True +-- | y == ':' && not (graphicChar x) = False + | x == '\\' && (isOpen y || isAlph y) = False + | isOpen x = False + | isClose y = False + | otherwise = True + where + isAlph c = isAlphaNum c || c `elem` ("'_" :: String) + isOpen c = c `elem` ("({[" :: String) + isClose c = c `elem` (")}]" :: String) --------------------------------------------------------------------------------- ANSI terminal colors +isOpName (c:cs) | c `elem` ("#<>!.:^&@|-+*/\\~%=$" :: String) = True +isOpName _ = False -pattern ESC a b <- (splitESC -> Just (a, b)) where ESC a b | 'm' `notElem` a = "\ESC[" ++ a ++ "m" ++ b +-------------------------------------------------------------------------- combinators -splitESC ('\ESC':'[': (span (/='m') -> (a, c: b))) | c == 'm' = Just (a, b) -splitESC _ = Nothing +-- add wl-pprint combinators as necessary here +red = DFormat P.dullred +green = DFormat P.dullgreen +blue = DFormat P.dullblue +white = DFormat P.white +onred = DFormat P.ondullred +ongreen = DFormat P.ondullgreen +onblue = DFormat P.ondullblue +underline = DFormat P.underline -withEsc i s = ESC (show i) $ s ++ ESC "" "" +-- add wl-pprint combinators as necessary here +hardline = dZero P.hardline +(<+>) = dTwo (P.<+>) +() = dTwo (P.) +(<$$>) = dTwo (P.<$$>) +nest n = dOne (P.nest n) +tupled = dList P.tupled +sep = dList P.sep +hsep = dList P.hsep +vcat = dList P.vcat -inGreen = withEsc 32 -inBlue = withEsc 34 -inRed = withEsc 31 -underlined = withEsc 47 +dZero x = DDocOp (const x) (Const ()) +dOne f = DDocOp (f . runIdentity) . Identity +dTwo f x y = DDocOp (\(Two x y) -> f x y) (Two x y) +dList f = DDocOp f -removeEscs :: String -> String -removeEscs (ESC _ cs) = removeEscs cs -removeEscs (c: cs) = c: removeEscs cs -removeEscs [] = [] +data Two a = Two a a + deriving (Functor, Foldable, Traversable) -correctEscs :: String -> String -correctEscs = (++ "\ESC[K") . f ["39","49"] where - f acc (ESC i@(_:_) cs) = esc (i /= head acc) i $ f (i: acc) cs - f (a: acc) (ESC "" cs) = esc (a /= head acc) (compOld (cType a) acc) $ f acc cs - f acc (c: cs) = c: f acc cs - f acc [] = [] +bracketed [] = text "[]" +bracketed xs = DPar "[" (foldr1 DComma xs) "]" - esc b i = if b then ESC i else id - compOld x xs = head $ filter ((== x) . cType) xs +shVar = DVar - cType n - | "30" <= n && n <= "39" = 0 - | "40" <= n && n <= "49" = 1 - | otherwise = 2 +shortForm d = DPar "" d "" +expand = DExpand -putStrLn_ = putStrLn . correctEscs -error_ = error . correctEscs -trace_ = trace . correctEscs -throwError_ = throwError . correctEscs +infixl 4 `DApp` +pattern DAt x = DGlue (InfixR 20) (DText "@") x +pattern DApp x y = DSep (InfixL 10) x y +pattern DHApp x y = DSep (InfixL 10) x (DAt y) +pattern DSemi x y = DOp ";" (InfixR (-19)) x y +pattern DArr_ s x y = DOp s (InfixR (-1)) x y -- -> => . +pattern DCstr x y = DOp "~" (Infix (-2)) x y +pattern DAnn x y = DOp "::" (Infix (-3)) x (DTypeNamespace True y) +pattern DLet s x y = DOp s (Infix (-4)) x y -- := = +pattern DComma a b = DOp "," (InfixR (-20)) a b +pattern DPar l d r = DAtom (ComplexAtom l (-20) d (SimpleAtom r)) + +pattern DParen x = DPar "(" x ")" +pattern DBrace x = DPar "{" x "}" +pattern DBracket x = DPar "[" x "]" +pattern DOp s f l r = DInfix f l (SimpleAtom s) r +pattern DOp0 s f = DOp s f (DText "") (DText "") +pattern DSep p a b = DOp " " p a b +pattern DGlue p a b = DOp "" p a b + +pattern DArr x y = DArr_ "->" x y + +braces = DBrace +parens = DParen + +shCstr = DCstr + +shTuple [] = "()" +shTuple [x] = DParen $ DParen x +shTuple xs = DParen $ foldr1 DComma xs + +shList [] = "[]" +shList xs = DBracket $ foldr1 DComma xs + +shAnn = DAnn + +shArr = DArr + + +pattern DForall s vs e = DArr_ s (DPreOp 10 (SimpleAtom "forall") vs) e +pattern DContext' vs e = DArr_ "->" (DAt vs) e +pattern DContext vs e = DArr_ "=>" vs e +pattern DParContext vs e = DContext (DParen vs) e +pattern DLam vs e = DPreOp (-10) (ComplexAtom "\\" 11 vs (SimpleAtom "->")) e +pattern DLet' vs e = DPreOp (-10) (ComplexAtom "let" (-20) vs (SimpleAtom "in")) e + +-------------------------------------------------------------------------------- + +class PShow a where + pShow :: a -> Doc + +ppShow :: PShow a => a -> String +ppShow = show . pShow + +tracePShow :: PShow a => a -> b -> b +tracePShow a b = trace (ppShow a) b + +instance PShow Doc where pShow = id +instance PShow Int where pShow = fromString . show +instance PShow Integer where pShow = fromString . show +instance PShow Double where pShow = fromString . show +instance PShow Char where pShow = fromString . show +instance PShow () where pShow _ = "()" + +instance PShow Bool where + pShow b = if b then "True" else "False" + +instance PShow Void where + pShow = elimVoid + +instance (PShow a, PShow b) => PShow (Either a b) where + pShow = either (("Left" `DApp`) . pShow) (("Right" `DApp`) . pShow) + +instance (PShow a, PShow b) => PShow (a, b) where + pShow (a, b) = tupled [pShow a, pShow b] + +instance (PShow a, PShow b, PShow c) => PShow (a, b, c) where + pShow (a, b, c) = tupled [pShow a, pShow b, pShow c] + +instance (PShow a, PShow b, PShow c, PShow d) => PShow (a, b, c, d) where + pShow (a, b, c, d) = tupled [pShow a, pShow b, pShow c, pShow d] + +instance (PShow a, PShow b, PShow c, PShow d, PShow e) => PShow (a, b, c, d, e) where + pShow (a, b, c, d, e) = tupled [pShow a, pShow b, pShow c, pShow d, pShow e] + +instance PShow a => PShow [a] where + pShow = bracketed . map pShow + +instance PShow a => PShow (Maybe a) where + pShow = maybe "Nothing" (("Just" `DApp`) . pShow) + +instance PShow a => PShow (Set.Set a) where + pShow s = "fromList" `DApp` pShow (Set.toList s) + +--instance (PShow s, PShow a) => PShow (Map s a) where +-- pShow = braces . vcat . map (\(k, t) -> pShow k <> P.colon <+> pShow t) . Map.toList + +-------------------------------------------------------- + +showNth n = show n ++ f (n `div` 10 `mod` 10) (n `mod` 10) + where + f 1 _ = "th" + f _ 1 = "st" + f _ 2 = "nd" + f _ 3 = "rd" + f _ _ = "th" + +toSubscript '0' = '₀' +toSubscript '1' = '₁' +toSubscript '2' = '₂' +toSubscript '3' = '₃' +toSubscript '4' = '₄' +toSubscript '5' = '₅' +toSubscript '6' = '₆' +toSubscript '7' = '₇' +toSubscript '8' = '₈' +toSubscript '9' = '₉' +toSubscript _ = error "toSubscript" diff --git a/src/LambdaCube/Compiler/Statements.hs b/src/LambdaCube/Compiler/Statements.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/Statements.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module LambdaCube.Compiler.Statements where + +import Data.Maybe +import Data.List +import Data.Char +import Data.Function +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.IntMap as IM +import Control.Monad.Writer +import Control.Arrow hiding ((<+>)) + +import LambdaCube.Compiler.Utils +import LambdaCube.Compiler.DeBruijn +import LambdaCube.Compiler.Pretty hiding (braces, parens) +import LambdaCube.Compiler.DesugaredSource +import LambdaCube.Compiler.Patterns + +-------------------------------------------------------------------------------- declaration representation + +-- eliminated during parsing +data PreStmt + = Stmt Stmt + | TypeAnn SIName SExp + | TypeFamily SIName SExp{-type-} -- type family declaration + | FunAlt SIName [(Visibility, SExp)]{-TODO: remove-} GuardTrees + | Class SIName [SExp]{-parameters-} [(SIName, SExp)]{-method names and types-} + | Instance SIName [ParPat]{-parameter patterns-} [SExp]{-constraints-} [Stmt]{-method definitions-} + +instance PShow PreStmt where + pShow _ = text "PreStmt - TODO" + +instance DeBruijnify SIName PreStmt where + deBruijnify_ k v = \case + FunAlt n ts gue -> FunAlt n (map (second $ deBruijnify_ k v) ts) $ deBruijnify_ k v gue + x -> error $ "deBruijnify @ " ++ ppShow x + +mkLets :: [Stmt]{-where block-} -> SExp{-main expression-} -> SExp{-big let with lambdas; replaces global names with de bruijn indices-} +mkLets = mkLets_ SLet + +mkLets_ mkLet = mkLets' mkLet . concatMap desugarMutual . sortDefs + +mkLets' mkLet = f where + f [] e = e + f (StmtLet n x: ds) e = mkLet n x (deBruijnify [n] $ f ds e) + f (PrecDef{}: ds) e = f ds e + f (x: ds) e = error $ "mkLets: " ++ ppShow x + +type DefinedSet = Set.Set SName + +addForalls :: DefinedSet -> SExp -> SExp +addForalls defined x = foldl f x [v | v@(sName -> vh:_) <- reverse $ names x, sName v `notElem'` defined, isLower vh] + where + f e v = SPi Hidden (Wildcard SType) $ deBruijnify [v] e + + notElem' s@(Ticked s') m = Set.notMember s m && Set.notMember s' m -- TODO: review + notElem' s m = s `notElem` m + + names :: SExp -> [SIName] + names = nub . foldName pure + +------------------------------------------------------------------------ + +compileStmt' = compileStmt'_ SLHS SRHS SRHS + +compileStmt'_ lhs ulend lend ds = fmap concat . sequence $ map (compileStmt lhs (\si vt -> compileGuardTree ulend lend (Just si) vt . mconcat) ds) $ groupBy h ds where + h (FunAlt n _ _) (FunAlt m _ _) = m == n + h _ _ = False + +--compileStmt :: MonadWriter [ParseCheck] m => (SIName -> [(Visibility, SExp)] -> [GuardTrees] -> m SExp) -> [PreStmt] -> [PreStmt] -> m [Stmt] +compileStmt lhs compilegt ds = \case + [Instance{}] -> return [] + [Class n ps ms] -> do + cd <- compileStmt' $ + [ TypeAnn n $ foldr (SPi Visible) SConstraint ps ] + ++ [ funAlt n (map noTA ps) $ noGuards $ foldr (SAppV2 $ SBuiltin F'T2) (SBuiltin FCUnit) cstrs | Instance n' ps cstrs _ <- ds, n == n' ] + ++ [ funAlt n (replicate (length ps) (noTA $ PVarSimp $ dummyName "cst0")) $ noGuards $ SBuiltin FCEmpty `SAppV` sLit (LString $ "no instance of " ++ sName n ++ " on ???"{-TODO-})] + cds <- sequence + [ compileStmt'_ SLHS SRHS SRHS{-id-} + $ TypeAnn m (UncurryS (map ((,) Hidden) ps) $ SPi Hidden (SCW $ 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 $ noGuards {- -$ SLam Hidden (Wildcard SType) $ up1 -} $ SLet m' e $ sVar "cst" 0 + | Instance n' i cstrs alts <- ds, n' == n + , StLet m' ~Nothing e <- alts, m' == m + , let p = zip ((,) Hidden <$> ps) i ++ [((Hidden, Wildcard SType), PVarSimp $ dummyName "cst2")] + -- , let ic = patVars i + ] + ] + return $ cd ++ concat cds + [TypeAnn n t] -> return [Primitive n t | n `notElem` [n' | FunAlt n' _ _ <- ds]] + tf@[TypeFamily n t] -> case [d | d@(FunAlt n' _ _) <- ds, n' == n] of + [] -> return [Primitive n t] + alts -> compileStmt lhs compileGuardTrees' [TypeAnn n t] alts + fs@(FunAlt n vs _: _) -> case groupBy ((==) `on` fst) [(length vs, n) | FunAlt n vs _ <- fs] of + [gs@((num, _): _)] + | num == 0 && length gs > 1 -> fail $ "redefined " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd <$> gs) + | n `elem` [n' | TypeFamily n' _ <- ds] -> return [] + | otherwise -> do + cf <- compilegt (SIName_ (mconcat [sourceInfo n | FunAlt n _ _ <- fs]) (nameFixity n) $ sName n) vs [gt | FunAlt _ _ gt <- fs] + return [StLet n (listToMaybe [t | TypeAnn n' t <- ds, n' == n]{-TODO: fail if more-}) $ lhs n cf] + fs -> fail $ "different number of arguments of " ++ sName n ++ ":\n" ++ show (vcat $ pShow . sourceInfo . snd . head <$> fs) + [Stmt x] -> return [x] + where + noTA x = ((Visible, Wildcard SType), x) + +funAlt :: SIName -> [((Visibility, SExp), ParPat)] -> GuardTrees -> PreStmt +funAlt n pats gt = FunAlt n (fst <$> pats) $ compilePatts (map snd pats) gt + +funAlt' n ts x gt = FunAlt n ts $ compilePatts x gt + +desugarValueDef :: MonadWriter [ParseCheck] m => ParPat -> SExp -> m [PreStmt] +desugarValueDef p e = sequence + $ pure (FunAlt n [] $ noGuards e) + : [ FunAlt x [] . noGuards <$> compileCase (SGlobal n) [(p, noGuards $ SVar x i)] + | (i, x) <- zip [0..] dns + ] + where + dns = reverse $ getPVars p + n = mangleNames dns + +getLet (StmtLet x dx) = Just (x, dx) +getLet _ = Nothing + +fst' (x, _) = x -- TODO + +desugarMutual :: {-MonadWriter [ParseCheck] m => -} [Stmt] -> [Stmt] +desugarMutual [x@Primitive{}] = [x] +desugarMutual [x@Data{}] = [x] +desugarMutual [x@PrecDef{}] = [x] +desugarMutual [StLet n nt nd] = [StLet n nt $ addFix n nd] +--desugarMutual [StmtLet n nd] = [StmtLet n $ addFix n nd] -- TODO +desugarMutual (traverse getLet -> Just (unzip -> (ns, ds))) = fst' $ runWriter $ do + ss <- compileStmt'_ sLHS SRHS SRHS =<< desugarValueDef (foldr cHCons cHNil $ PVarSimp <$> ns) (SGlobal xy) + return $ StmtLet xy (addFix xy $ mkLets' SLet ss $ foldr HCons HNil ds) : ss + + where + xy = mangleNames ns +desugarMutual xs = error "desugarMutual" + +addFix n x + | usedS n x = SBuiltin FprimFix `SAppV` SLamV (deBruijnify [n] x) + | otherwise = x + +mangleNames xs = SIName (foldMap sourceInfo xs) $ "_" ++ intercalate "_" (sName <$> xs) + +-------------------------------------------------------------------------------- statement with dependencies + +data StmtNode = StmtNode + { snId :: !Int + , snValue :: Stmt + , snChildren :: [StmtNode] + , snRevChildren :: [StmtNode] + } + +sortDefs :: [Stmt] -> [[Stmt]] +sortDefs xs = map snValue <$> scc snId snChildren snRevChildren nodes + where + nodes = zipWith mkNode [0..] xs + where + mkNode i s = StmtNode i s (nubBy ((==) `on` snId) $ catMaybes $ (`Map.lookup` defMap) <$> need) + (fromMaybe [] $ IM.lookup i revMap) + where + need = Set.toList $ case s of + PrecDef{} -> mempty + StLet _ mt e -> foldMap names mt <> names e + Data _ ps t cs -> foldMap (names . snd) ps <> names t <> foldMap (names . snd) cs + + names = foldName Set.singleton + + revMap = IM.unionsWith (++) [IM.singleton (snId c) [n] | n <- nodes, c <- snChildren n] + + defMap = Map.fromList [(s, n) | n <- nodes, s <- def $ snValue n] + where + def = \case + PrecDef{} -> mempty + StLet n _ _ -> [n] + Data n _ _ cs -> n: map fst cs + + diff --git a/src/LambdaCube/Compiler/Utils.hs b/src/LambdaCube/Compiler/Utils.hs new file mode 100644 --- /dev/null +++ b/src/LambdaCube/Compiler/Utils.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module LambdaCube.Compiler.Utils where + +import qualified Data.IntSet as IS +import qualified Data.Text as T +import qualified Text.Show.Pretty as PP +--import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.RWS +import System.Directory +import qualified Data.Text.IO as TIO +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Prim as P + +------------------------------------------------------- general functions + +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip (<$>) + +dropIndex :: Int -> [a] -> [a] +dropIndex i xs = take i xs ++ drop (i+1) xs + +iterateN :: Int -> (a -> a) -> a -> a +iterateN n f e = iterate f e !! n + +foldlrev f = foldr (flip f) + +------------------------------------------------------- Void data type + +data Void + +instance Eq Void where x == y = elimVoid x + +elimVoid :: Void -> a +elimVoid v = case v of + +------------------------------------------------------- supplementary data wrapper + +-- supplementary data: data with no semantic relevance +newtype SData a = SData a + +instance Eq (SData a) where _ == _ = True +instance Ord (SData a) where _ `compare` _ = EQ + +------------------------------------------------------- strongly connected component calculation + +type Children k = k -> [k] + +data Task a = Return a | Visit a + +scc :: forall k . (k -> Int) -> Children k -> Children k -> [k]{-roots-} -> [[k]] +scc key children revChildren + = filter (not . null) . uncurry (revMapWalk revChildren) . revPostOrderWalk children + where + revPostOrderWalk :: Children k -> [k] -> (IS.IntSet, [k]) + revPostOrderWalk children = collect IS.empty [] . map Visit where + + collect s acc [] = (s, acc) + collect s acc (Return h: t) = collect s (h: acc) t + collect s acc (Visit h: t) + | key h `IS.member` s = collect s acc t + | otherwise = collect (IS.insert (key h) s) acc $ map Visit (children h) ++ Return h: t + + revMapWalk :: Children k -> IS.IntSet -> [k] -> [[k]] + revMapWalk children = f [] + where + f acc s [] = acc + f acc s (h:t) = f (c: acc) s' t + where (s', c) = collect s [] [h] + + collect s acc [] = (s, acc) + collect s acc (h:t) + | not (key h `IS.member` s) = collect s acc t + | otherwise = collect (IS.delete (key h) s) (h: acc) (children h ++ t) + +------------------------------------------------------- wrapped pretty show + +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 + + isMultilineString ('\\':'n':xs) = True + isMultilineString ('\\':c:xs) = isMultilineString xs + isMultilineString ('"':xs) = False + isMultilineString (x:xs) = isMultilineString xs + isMultilineString [] = False + +------------------------------------------------------- file handling + +readFileStrict :: FilePath -> IO String +readFileStrict = fmap T.unpack . TIO.readFile + +readFileIfExists :: FilePath -> IO (Maybe (IO String)) +readFileIfExists fname = do + b <- doesFileExist fname + return $ if b then Just $ readFileStrict fname else Nothing + +------------------------------------------------------- missing instances +{- +instance MonadMask m => MonadMask (ExceptT e m) where + mask f = ExceptT $ mask $ \u -> runExceptT $ f (mapExceptT u) + uninterruptibleMask = error "not implemented: uninterruptibleMask for ExcpetT" +-} + +instance (Monoid w, P.MonadParsec e s m) => P.MonadParsec e s (RWST r w st m) where + failure a b = lift . P.failure a b + label = mapRWST . P.label + try = mapRWST P.try + lookAhead (RWST m) = RWST $ \r s -> (\(a, _, _) -> (a, s, mempty)) <$> P.lookAhead (m r s) + notFollowedBy (RWST m) = RWST $ \r s -> P.notFollowedBy ((\(a, _, _) -> a) <$> m r s) >> return ((), s, mempty) + withRecovery rec (RWST m) = RWST $ \r s -> P.withRecovery (\e -> runRWST (rec e) r s) (m r s) + eof = lift P.eof + token f e = lift $ P.token f e + tokens f e = lift $ P.tokens f e + getParserState = lift P.getParserState + updateParserState f = lift $ P.updateParserState f + diff --git a/test/PerfReport.hs b/test/PerfReport.hs --- a/test/PerfReport.hs +++ b/test/PerfReport.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards #-} +import Data.Monoid import Data.Char import System.Directory import System.FilePath 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.Megaparsec.Pos (SourcePos(..), newPos, sourceName, sourceLine, sourceColumn) +import Text.Megaparsec.Pos (Pos, unsafePos, SourcePos(..), sourceName, sourceLine, sourceColumn) import qualified Data.Map as Map import qualified Data.Set as Set @@ -11,7 +11,8 @@ import Test.Tasty import Test.Tasty.QuickCheck -import LambdaCube.Compiler.Infer +import LambdaCube.Compiler.DesugaredSource +import LambdaCube.Compiler.Core ----------------------------------------------------------------- Main @@ -27,21 +28,29 @@ ----------------------------------------------------------------- Arbitraries -- SourcePos +instance Arbitrary Pos where + arbitrary = unsafePos . getPositive <$> arbitrary instance Arbitrary SourcePos where - arbitrary = newPos <$> arbitrary <*> (getPositive <$> arbitrary) <*> (getPositive <$> arbitrary) + arbitrary = SourcePos <$> arbitrary <*> arbitrary <*> 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] + = [SourcePos n' l' c' | n' <- shrink n, l' <- shrink l, c' <- shrink c] -- TODO: Diagonalize shrink --- Range +-- TODO: generate only valid positions +instance Arbitrary SPos where + arbitrary = SPos <$> arbitrary <*> arbitrary -instance Arbitrary Range where - arbitrary = Range <$> arbitrary <*> arbitrary - shrink (Range a b) = Range <$> shrink a <*> shrink b +-- TODO: review +instance Arbitrary FileInfo where + arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -deriving instance Show Range +-- Range +instance Arbitrary Range where + -- TODO: generate only valid ranges (positive numbers, second position is after first one) + arbitrary = Range <$> arbitrary <*> arbitrary <*> arbitrary + shrink (Range a b c) = Range <$> shrink a <*> shrink b <*> shrink c -- SI diff --git a/test/runTests.hs b/test/runTests.hs --- a/test/runTests.hs +++ b/test/runTests.hs @@ -3,20 +3,27 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where +import Data.Monoid import Data.Char import Data.List --import Data.Either +import qualified Data.Map.Strict as Map import Data.Time.Clock import Data.Algorithm.Patience import Control.Applicative -import Control.Arrow +import Control.Arrow hiding ((<+>)) import Control.Concurrent import Control.Concurrent.Async import Control.Monad import Control.Monad.Reader -import Control.Exception hiding (catch) +--import Control.Monad.Except +import Control.Monad.Catch +import Control.Exception hiding (catch, bracket, finally, mask) +--import Control.Exception hiding (catch) import Control.Monad.Trans.Control import Control.DeepSeq import System.Exit @@ -34,6 +41,8 @@ ------------------------------------------ utils +(<&>) = flip (<$>) + readFileStrict :: FilePath -> IO String readFileStrict = fmap T.unpack . TIO.readFile @@ -64,19 +73,26 @@ where t = realToFrac delta :: Double -timeOut :: MonadBaseControl IO m => NominalDiffTime -> a -> m a -> m (NominalDiffTime, a) +timeOut :: forall m a . MonadBaseControl IO m => NominalDiffTime -> a -> m a -> m (NominalDiffTime, a) timeOut dt d m = control $ \runInIO -> race' (runInIO $ timeDiff m) (runInIO $ timeDiff $ liftIO (threadDelay $ round $ dt * 1000000) >> return d) where - liftIO = liftBaseWith . const + liftIO :: IO b -> m b + liftIO m = liftBaseWith (const m) race' a b = either id id <$> race a b timeDiff m = (\s x e -> (diffUTCTime e s, x)) <$> liftIO getCurrentTime <*> m <*> liftIO getCurrentTime +catchErr :: (MonadCatch m, NFData a, MonadIO m) => (String -> m a) -> m a -> m a +catchErr er m = (force <$> m >>= liftIO . evaluate) `catch` getErr `catch` getPMatchFail + where + getErr (e :: ErrorCall) = catchErr er $ er $ show e + getPMatchFail (e :: PatternMatchFail) = catchErr er $ er $ show e + ------------------------------------------ testDataPath = "./testdata" @@ -120,6 +136,13 @@ isWip = (".wip" `elem`) . takeExtensions' isReject = (".reject" `elem`) . takeExtensions' +-- for the repl +parse srcName = do + pplRes <- parseModule ["testdata"] (srcName ++ ".lc") + case pplRes of + Left err -> fail $ show err + Right ppl -> putStrLn ppl + main :: IO () main = do hSetBuffering stdout NoBuffering @@ -197,23 +220,46 @@ (splitMPath -> (pa, mn', mn), reverse -> exts) = splitExtensions' $ dropExtension fn 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 + res <- local (const $ ioFetch [pa]) $ loadModule id Nothing (Left $ mn' ++ concat exts ++ ".lc") <&> \case + Left err -> (mempty, Left (Nothing, err)) + Right (fname, (src, Left err)) -> (mempty, Left (Just fname, err)) + Right (fname, (src, Right (pm, infos, Left err))) -> (,) infos $ Left (Just fname, err) + Right (fname, (src, Right (pm, infos, Right (_, ge)))) -> (,) infos $ Right + ( fname + , ge + , case Map.lookup "main" ge of + Just (e, thy, si) -> Right (ET e thy) + Nothing -> Left $ text "main" <+> "is not found" + ) + case res of + (_, Right (fi, _, Right{})) -> removeFromCache $ filePath fi + _ -> return () + return res - 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) + --getDef :: MonadMask m => FilePath -> SName -> Maybe Exp -> MMT m (Infos, [Stmt]) ((Infos, [Stmt]), Either Doc (FilePath, Either Doc ExpType)) + + f ((i, desug), e) | not $ isReject fn = case e of + Left (_, show -> e) -> Left (unlines $ tab "!Failed" e: map show (listTraceInfos i), Failed) + Right (fname, ge, Left (pShow -> e)) + -> Right ("typechecked module", simpleShow $ vcat $ e: showGE fname ge) + Right (fname, ge, Right (ET e te)) + | te == outputType -> Right ("compiled pipeline", prettyShowUnlines $ compilePipeline OpenGL33 (ET e te)) + | e == trueExp -> Right ("reducted main", de) + | te == boolType -> Left (tab "!Failed" $ "main should be True but it is \n" ++ simpleShow res, Failed) + | otherwise -> Right ("reduced main :: " ++ simpleShow (mkDoc (True, False) te), de) + where + de = simpleShow $ vcat $ (DAnn "main" $ pShow te) : (DLet "=" "main" res): showGE fname ge + res = mkDoc (True, False) e | otherwise = case e of - Left e -> Right ("error message", unlines $ e: listAllInfos i) + Left (fn, pShow -> e) -> Right ("error message", simpleShow $ vcat $ e: listAllInfos fn i) Right _ -> Left (tab "!Failed" "failed to catch error", Failed) + where + showGE fname ge = "------------ desugared source code": intersperse "" (map pShow desug) + ++ "------------ core code": intersperse "" + [ DAnn (text n) (DResetFreshNames $ pShow t) + <$$> DLet "=" (text n) (DResetFreshNames $ mkDoc (False, True) e) + | (n, (e, t, RangeSI r)) <- Map.toList ge, rangeFile r == fname] + ++ listAllInfos' (Just fname) i tab msg | isWip fn && cfgReject = const msg @@ -228,22 +274,22 @@ 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 + rs -> do mapM_ putStrLn $ printOldNew msg d putStrLn $ ef ++ " has changed." - putStr $ "Accept new " ++ msg ++ " (y/n)? " - c <- getYNChar - if c - then writeFile ef e >> return ("Accepted .out file", Accepted) - else return ("!Rejected .out file", Rejected) + if cfgReject then return ("!Different .out file", Rejected) else do + putStr $ "Accept new " ++ msg ++ " (y/n)? " + c <- getYNChar + if c + then writeFile ef e >> return ("Accepted .out file", Accepted) + else return ("!Rejected .out file", Rejected) 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 acc n (Old a: ds) = g acc n ++ (show (onred "< ") ++ a): ff [] 0 ds + ff acc n (New b: ds) = g acc n ++ (show (ongreen "> ") ++ b): ff [] 0 ds ff _ _ [] = [] g acc n | n < 5 = [] g acc n | n > 10 = "___________": reverse (take 5 acc) diff --git a/tool/Compiler.hs b/tool/Compiler.hs --- a/tool/Compiler.hs +++ b/tool/Compiler.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE RecordWildCards #-} +import Data.Monoid +import Control.Monad import Options.Applicative import Data.Aeson import qualified Data.ByteString.Lazy as B @@ -8,53 +9,66 @@ import LambdaCube.Compiler -data Config - = Config - { srcName :: String - , backend :: Backend - , includePaths :: [FilePath] - , pretty :: Bool - , output :: Maybe String - } - -sample :: Parser Config -sample = Config - <$> 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")) +addInfo i p = info (helper <*> p) i main :: IO () -main = compile =<< execParser opts +main = join $ execParser $ addInfo i $ versionOption <*> subparser ( + command "compile" (addInfo (progDesc "compiles LambdaCube3D source to JSON IR") compile') + <> command "parse" (addInfo (progDesc "parses LambdaCube3D source") $ parse + <$> argument str (metavar "SOURCE_FILE") + <*> flag OpenGL33 WebGL1 (long "webgl" <> help "generate WebGL 1.0 pipeline" ) + <*> pure ["."] + <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name")) + ) + <> command "pretty" (addInfo (progDesc "pretty prints JSON IR") $ prettyPrint + <$> argument str (metavar "SOURCE_FILE") + <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name")) + )) <|> compile' where - opts = info (helper <*> sample) - ( fullDesc - <> progDesc "compiles LambdaCube graphics pipeline source to JSON IR" - <> header ("LambdaCube 3D compiler " ++ showVersion version)) + compile' = (compile + <$> argument str (metavar "SOURCE_FILE") + <*> flag OpenGL33 WebGL1 (long "webgl" <> help "generate WebGL 1.0 pipeline" ) + <*> pure ["."] + <*> optional (strOption (long "output" <> short 'o' <> metavar "FILENAME" <> help "output file name")) + ) -compile :: Config -> IO () -compile cfg@Config{..} = do + i = fullDesc + <> progDesc "executes command (default to compile if no command is given)" + <> header versionStr + +versionStr :: String +versionStr = "LambdaCube 3D compiler " ++ showVersion version + +versionOption :: Parser (a -> a) +versionOption = abortOption (InfoMsg versionStr) $ mconcat + [ long "version" + , short 'v' + , help "Print version." + ] + +prettyPrint srcName output = 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 -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl + +parse srcName backend includePaths output = do + pplRes <- parseModule includePaths srcName + case pplRes of + Left err -> fail $ show err + Right ppl -> maybe (putStrLn ppl) (`writeFile` ppl) output + +compile srcName backend includePaths output = 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 + 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 -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl + Left err -> fail $ show err + Right ppl -> B.writeFile (withOutName $ baseName <> ".json") $ encode ppl +-- True -> writeFile (withOutName $ baseName <> ".ppl") $ prettyShowUnlines ppl