├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── shell.nix ├── src ├── Ast.hs ├── Ast │ ├── Error.hs │ ├── Error │ │ ├── Common.hs │ │ └── Common │ │ │ ├── Kind.hs │ │ │ └── Type.hs │ ├── Kind.hs │ ├── Kind │ │ └── Var.hs │ ├── Pattern.hs │ ├── Term.hs │ ├── Term │ │ └── Var.hs │ ├── Type.hs │ ├── Type │ │ └── Var.hs │ └── Warning.hs ├── Context │ ├── Term.hs │ ├── Term │ │ └── Error.hs │ ├── Type.hs │ └── Type │ │ └── Error.hs ├── Data │ ├── Bitransversable.hs │ └── Functor │ │ └── Rec.hs ├── Fragment │ ├── Annotation.hs │ ├── Annotation │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Term.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Ast2.hs │ ├── Bool.hs │ ├── Bool │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Pattern.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Case.hs │ ├── Case │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Term.hs │ │ │ └── Warning.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Fix.hs │ ├── Fix │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Term.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── HM.hs │ ├── If.hs │ ├── If │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Term.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Int.hs │ ├── Int │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Pattern.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Class.hs │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── IsoRec.hs │ ├── IsoRec │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ └── SyntaxDirected.hs │ ├── KiArr.hs │ ├── KiArr │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ └── Kind.hs │ │ ├── Helpers.hs │ │ └── Rules │ │ │ └── Kind │ │ │ └── Infer │ │ │ └── Common.hs │ ├── KiBase.hs │ ├── KiBase │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Kind.hs │ │ └── Helpers.hs │ ├── LC.hs │ ├── LC │ │ ├── Ast.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ └── Term.hs │ ├── Let.hs │ ├── Let │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Term.hs │ │ └── Helpers.hs │ ├── Pair.hs │ ├── Pair │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Pattern.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── PtVar.hs │ ├── PtVar │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── PtWild.hs │ ├── PtWild │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Record.hs │ ├── Record │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Pattern.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── STLC.hs │ ├── SystemF.hs │ ├── SystemF │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ └── SyntaxDirected.hs │ ├── SystemFw.hs │ ├── SystemFw │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Kind.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ └── SyntaxDirected.hs │ ├── TmApp.hs │ ├── TmApp │ │ ├── Ast.hs │ │ ├── Ast │ │ │ └── Term.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── TmLam.hs │ ├── TmLam │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ └── Term.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Term.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── TmVar.hs │ ├── TmVar │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Tuple.hs │ ├── Tuple │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ ├── Pattern.hs │ │ │ ├── Term.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Term.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── TyAll.hs │ ├── TyAll │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ └── Common.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ └── Common.hs │ ├── TyArr.hs │ ├── TyArr │ │ ├── Ast.hs │ │ ├── Ast │ │ │ ├── Error.hs │ │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ ├── Type.hs │ │ │ └── Type │ │ │ └── Infer │ │ │ ├── Common.hs │ │ │ └── Offline.hs │ ├── TyVar.hs │ ├── TyVar │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ │ ├── Kind │ │ │ └── Infer │ │ │ │ ├── Common.hs │ │ │ │ └── SyntaxDirected.hs │ │ │ └── Type.hs │ ├── Variant.hs │ └── Variant │ │ ├── Ast.hs │ │ ├── Ast │ │ ├── Error.hs │ │ ├── Pattern.hs │ │ ├── Term.hs │ │ └── Type.hs │ │ ├── Helpers.hs │ │ ├── Rules.hs │ │ └── Rules │ │ ├── Kind │ │ └── Infer │ │ │ ├── Common.hs │ │ │ └── SyntaxDirected.hs │ │ ├── Term.hs │ │ ├── Type.hs │ │ └── Type │ │ └── Infer │ │ ├── Common.hs │ │ ├── Offline.hs │ │ └── SyntaxDirected.hs ├── Language │ └── TheLot.hs ├── Rules.hs ├── Rules │ ├── Infer │ │ └── Unification.hs │ ├── Kind │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ ├── Pattern.hs │ ├── Term.hs │ ├── Type.hs │ ├── Type │ │ └── Infer │ │ │ ├── Common.hs │ │ │ ├── Offline.hs │ │ │ └── SyntaxDirected.hs │ └── Unification.hs └── Util │ ├── MonadProxy.hs │ ├── NonEmpty.hs │ ├── Prisms.hs │ └── TypeList.hs └── type-system.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | TAGS 3 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Dave Laing 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Dave Laing nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, ansi-wl-pprint, base, bound, containers 2 | , deriving-compat, equivalence, errors, lens, mtl, parsers, safe 3 | , semigroupoids, semigroups, stdenv, text, transformers, trifecta 4 | , unordered-containers 5 | }: 6 | mkDerivation { 7 | pname = "type-systems"; 8 | version = "0.1.0.0"; 9 | src = ./.; 10 | libraryHaskellDepends = [ 11 | ansi-wl-pprint base bound containers deriving-compat equivalence 12 | errors lens mtl parsers safe semigroupoids semigroups text 13 | transformers trifecta unordered-containers 14 | ]; 15 | license = stdenv.lib.licenses.bsd3; 16 | } 17 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "ghc802", withProfiling ? false, withHoogle ? true }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | lib = import "${nixpkgs.path}/pkgs/development/haskell-modules/lib.nix" { pkgs = nixpkgs; }; 7 | 8 | haskellPackagesWithCompiler = 9 | if compiler == "default" 10 | then pkgs.haskellPackages 11 | else pkgs.haskell.packages.${compiler}; 12 | 13 | haskellPackagesWithProfiling = 14 | if withProfiling 15 | then haskellPackagesWithCompiler.override { 16 | overrides = self: super: { 17 | mkDerivation = args: super.mkDerivation (args // { enableLibraryProfiling = true; }); 18 | }; 19 | } 20 | else haskellPackagesWithCompiler; 21 | 22 | haskellPackagesWithHoogle = 23 | if withHoogle 24 | then haskellPackagesWithProfiling.override { 25 | overrides = self: super: { 26 | ghc = super.ghc // { withPackages = super.ghc.withHoogle; }; 27 | ghcWithPackages = self.ghc.withPackages; 28 | }; 29 | } 30 | else haskellPackagesWithProfiling; 31 | 32 | drv = haskellPackagesWithHoogle.callPackage ./. {}; 33 | 34 | in 35 | 36 | if pkgs.lib.inNixShell then drv.env else drv 37 | -------------------------------------------------------------------------------- /src/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | module Ast.Error ( 16 | ErrSum(..) 17 | , _ErrNow 18 | , _ErrNext 19 | ) where 20 | 21 | import Control.Lens.Prism (Prism', prism) 22 | 23 | data ErrSum (f :: [*]) where 24 | ErrNext :: ErrSum g -> ErrSum (f ': g) 25 | ErrNow :: f -> ErrSum (f ': g) 26 | 27 | _ErrNext :: Prism' (ErrSum (f ': g)) (ErrSum g) 28 | _ErrNext = prism ErrNext $ \x -> case x of 29 | ErrNext y -> Right y 30 | _ -> Left x 31 | 32 | _ErrNow :: Prism' (ErrSum (f ': g)) f 33 | _ErrNow = prism ErrNow $ \x -> case x of 34 | ErrNow y -> Right y 35 | _ -> Left x 36 | 37 | instance Eq (ErrSum '[]) where 38 | _ == _ = True 39 | 40 | instance (Eq x, Eq (ErrSum xs)) => Eq (ErrSum (x ': xs)) where 41 | ErrNow a1 == ErrNow a2 = a1 == a2 42 | ErrNext n1 == ErrNext n2 = n1 == n2 43 | _ == _ = False 44 | 45 | instance Ord (ErrSum '[] ) where 46 | compare _ _ = EQ 47 | 48 | instance (Ord x, Ord (ErrSum xs)) => Ord (ErrSum (x ': xs)) where 49 | compare (ErrNow a1) (ErrNow a2) = compare a1 a2 50 | compare (ErrNow _) _ = LT 51 | compare _ (ErrNow _) = GT 52 | compare (ErrNext n1) (ErrNext n2) = compare n1 n2 53 | 54 | instance Show (ErrSum '[]) where 55 | showsPrec _ _ = id 56 | 57 | instance (Show x, Show (ErrSum xs)) => Show (ErrSum (x ': xs)) where 58 | showsPrec m (ErrNow a) = showString "ErrSum " . showsPrec m a 59 | showsPrec m (ErrNext n) = showsPrec m n 60 | -------------------------------------------------------------------------------- /src/Ast/Error/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Ast.Error.Common ( 9 | module X 10 | ) where 11 | 12 | import Ast.Error.Common.Kind as X 13 | import Ast.Error.Common.Type as X 14 | -------------------------------------------------------------------------------- /src/Ast/Kind/Var.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | module Ast.Kind.Var ( 12 | HasKiVarSupply(..) 13 | , ToKiVar(..) 14 | , freshKiVar 15 | ) where 16 | 17 | import Control.Monad.State (MonadState) 18 | import Control.Lens (Lens', use, (%=)) 19 | 20 | import qualified Data.Text as T 21 | 22 | class HasKiVarSupply s where 23 | kiVarSupply :: Lens' s Int 24 | 25 | instance HasKiVarSupply Int where 26 | kiVarSupply = id 27 | 28 | class ToKiVar a where 29 | toKiVar :: Int -> a 30 | 31 | instance ToKiVar String where 32 | toKiVar x = 'k' : show x 33 | 34 | instance ToKiVar T.Text where 35 | toKiVar x = T.append "k" (T.pack . show $ x) 36 | 37 | freshKiVar :: (MonadState s m, HasKiVarSupply s, ToKiVar a) => m a 38 | freshKiVar = do 39 | x <- use kiVarSupply 40 | kiVarSupply %= succ 41 | return $ toKiVar x 42 | -------------------------------------------------------------------------------- /src/Ast/Term/Var.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | module Ast.Term.Var ( 12 | HasTmVarSupply(..) 13 | , ToTmVar(..) 14 | , freshTmVar 15 | ) where 16 | 17 | import Control.Monad.State (MonadState) 18 | import Control.Lens (Lens', use, (%=)) 19 | 20 | import qualified Data.Text as T 21 | 22 | class HasTmVarSupply s where 23 | tmVarSupply :: Lens' s Int 24 | 25 | instance HasTmVarSupply Int where 26 | tmVarSupply = id 27 | 28 | class ToTmVar a where 29 | toTmVar :: Int -> a 30 | 31 | instance ToTmVar String where 32 | toTmVar x = 'x' : show x 33 | 34 | instance ToTmVar T.Text where 35 | toTmVar x = T.append "x" (T.pack . show $ x) 36 | 37 | freshTmVar :: (MonadState s m, HasTmVarSupply s, ToTmVar a) => m a 38 | freshTmVar = do 39 | x <- use tmVarSupply 40 | tmVarSupply %= succ 41 | return $ toTmVar x 42 | -------------------------------------------------------------------------------- /src/Ast/Type/Var.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeSynonymInstances #-} 9 | {-# LANGUAGE FlexibleInstances #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | module Ast.Type.Var ( 12 | HasTyVarSupply(..) 13 | , ToTyVar(..) 14 | , freshTyVar 15 | ) where 16 | 17 | import Control.Monad.State (MonadState) 18 | import Control.Lens (Lens', use, (%=)) 19 | 20 | import qualified Data.Text as T 21 | 22 | class HasTyVarSupply s where 23 | tyVarSupply :: Lens' s Int 24 | 25 | instance HasTyVarSupply Int where 26 | tyVarSupply = id 27 | 28 | class ToTyVar a where 29 | toTyVar :: Int -> a 30 | 31 | instance ToTyVar String where 32 | toTyVar x = 'x' : show x 33 | 34 | instance ToTyVar T.Text where 35 | toTyVar x = T.append "x" (T.pack . show $ x) 36 | 37 | freshTyVar :: (MonadState s m, HasTyVarSupply s, ToTyVar a) => m a 38 | freshTyVar = do 39 | x <- use tyVarSupply 40 | tyVarSupply %= succ 41 | return $ toTyVar x 42 | -------------------------------------------------------------------------------- /src/Ast/Warning.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE GADTs #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE FlexibleContexts #-} 15 | module Ast.Warning ( 16 | WarnSum(..) 17 | , _WarnNow 18 | , _WarnNext 19 | ) where 20 | 21 | import Control.Lens.Prism (Prism', prism) 22 | 23 | data WarnSum (f :: [*]) where 24 | WarnNext :: WarnSum g -> WarnSum (f ': g) 25 | WarnNow :: f -> WarnSum (f ': g) 26 | 27 | _WarnNext :: Prism' (WarnSum (f ': g)) (WarnSum g) 28 | _WarnNext = prism WarnNext $ \x -> case x of 29 | WarnNext y -> Right y 30 | _ -> Left x 31 | 32 | _WarnNow :: Prism' (WarnSum (f ': g)) f 33 | _WarnNow = prism WarnNow $ \x -> case x of 34 | WarnNow y -> Right y 35 | _ -> Left x 36 | 37 | instance Eq (WarnSum '[]) where 38 | _ == _ = True 39 | 40 | instance (Eq x, Eq (WarnSum xs)) => Eq (WarnSum (x ': xs)) where 41 | WarnNow a1 == WarnNow a2 = a1 == a2 42 | WarnNext n1 == WarnNext n2 = n1 == n2 43 | _ == _ = False 44 | 45 | instance Ord (WarnSum '[] ) where 46 | compare _ _ = EQ 47 | 48 | instance (Ord x, Ord (WarnSum xs)) => Ord (WarnSum (x ': xs)) where 49 | compare (WarnNow a1) (WarnNow a2) = compare a1 a2 50 | compare (WarnNow _) _ = LT 51 | compare _ (WarnNow _) = GT 52 | compare (WarnNext n1) (WarnNext n2) = compare n1 n2 53 | 54 | instance Show (WarnSum '[]) where 55 | showsPrec _ _ = id 56 | 57 | instance (Show x, Show (WarnSum xs)) => Show (WarnSum (x ': xs)) where 58 | showsPrec m (WarnNow a) = showString "WarnSum " . showsPrec m a 59 | showsPrec m (WarnNext n) = showsPrec m n 60 | -------------------------------------------------------------------------------- /src/Context/Term/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Context.Term.Error ( 17 | ErrUnboundTermVariable(..) 18 | , AsUnboundTermVariable(..) 19 | ) where 20 | 21 | import Control.Lens.Prism (Prism') 22 | import Control.Lens.TH (makePrisms) 23 | 24 | import Ast.Error 25 | 26 | data ErrUnboundTermVariable a = ErrUnboundTermVariable a 27 | deriving (Eq, Ord, Show) 28 | 29 | makePrisms ''ErrUnboundTermVariable 30 | 31 | class AsUnboundTermVariable e a where -- | e -> a where 32 | _UnboundTermVariable :: Prism' e a 33 | 34 | instance AsUnboundTermVariable (ErrUnboundTermVariable a) a where 35 | _UnboundTermVariable = _ErrUnboundTermVariable 36 | 37 | instance {-# OVERLAPPABLE #-} AsUnboundTermVariable (ErrSum xs) a => AsUnboundTermVariable (ErrSum (x ': xs)) a where 38 | _UnboundTermVariable = _ErrNext . _UnboundTermVariable 39 | 40 | instance {-# OVERLAPPING #-} AsUnboundTermVariable (ErrSum (ErrUnboundTermVariable a ': xs)) a where 41 | _UnboundTermVariable = _ErrNow . _UnboundTermVariable 42 | -------------------------------------------------------------------------------- /src/Context/Type/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Context.Type.Error ( 17 | ErrUnboundTypeVariable(..) 18 | , AsUnboundTypeVariable(..) 19 | ) where 20 | 21 | import Control.Lens.Prism (Prism') 22 | import Control.Lens.TH (makePrisms) 23 | 24 | import Ast.Error 25 | 26 | data ErrUnboundTypeVariable a = ErrUnboundTypeVariable a 27 | deriving (Eq, Ord, Show) 28 | 29 | makePrisms ''ErrUnboundTypeVariable 30 | 31 | class AsUnboundTypeVariable e a where -- | e -> a where 32 | _UnboundTypeVariable :: Prism' e a 33 | 34 | instance AsUnboundTypeVariable (ErrUnboundTypeVariable a) a where 35 | _UnboundTypeVariable = _ErrUnboundTypeVariable 36 | 37 | instance {-# OVERLAPPABLE #-} AsUnboundTypeVariable (ErrSum xs) a => AsUnboundTypeVariable (ErrSum (x ': xs)) a where 38 | _UnboundTypeVariable = _ErrNext . _UnboundTypeVariable 39 | 40 | instance {-# OVERLAPPING #-} AsUnboundTypeVariable (ErrSum (ErrUnboundTypeVariable a ': xs)) a where 41 | _UnboundTypeVariable = _ErrNow . _UnboundTypeVariable 42 | -------------------------------------------------------------------------------- /src/Data/Bitransversable.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE RankNTypes #-} 9 | module Data.Bitransversable ( 10 | Bitransversable(..) 11 | , traverseDefault 12 | ) where 13 | 14 | import Bound.Scope (Scope, bitransverseScope) 15 | 16 | class Bitransversable s where 17 | bitransverse :: Applicative f => (forall a b. (a -> f b) -> t a -> f (u b)) -> (c -> f d) -> s t c -> f (s u d) 18 | 19 | instance Bitransversable (Scope b) where 20 | bitransverse = bitransverseScope 21 | 22 | traverseDefault :: (Applicative f, Traversable r, Bitransversable t) => (a -> f b) -> t r a -> f (t r b) 23 | traverseDefault = bitransverse traverse 24 | -------------------------------------------------------------------------------- /src/Fragment/Annotation.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.Annotation ( 13 | module X 14 | , AnnotationTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | 24 | import Fragment.Annotation.Ast as X 25 | import Fragment.Annotation.Helpers as X 26 | 27 | import Fragment.Annotation.Rules.Type.Infer.Common 28 | import Fragment.Annotation.Rules.Term 29 | 30 | data AnnotationTag 31 | 32 | instance AstIn AnnotationTag where 33 | type KindList AnnotationTag = '[] 34 | type TypeList AnnotationTag = '[] 35 | type TypeSchemeList AnnotationTag = '[] 36 | type PatternList AnnotationTag = '[] 37 | type TermList AnnotationTag = '[TmFAnnotation] 38 | 39 | instance EvalRules e AnnotationTag where 40 | type EvalConstraint ki ty pt tm a e AnnotationTag = 41 | AnnotationEvalConstraint ki ty pt tm a 42 | 43 | evalInput _ _ = 44 | annotationEvalRules 45 | 46 | instance NormalizeRules AnnotationTag where 47 | type NormalizeConstraint ki ty a AnnotationTag = 48 | (() :: Constraint) 49 | 50 | normalizeInput _ = 51 | mempty 52 | 53 | instance MkInferType i => InferTypeRules i AnnotationTag where 54 | type InferTypeConstraint e w s r m ki ty pt tm a i AnnotationTag = 55 | AnnotationInferTypeConstraint e w s r m ki ty pt tm a i 56 | type InferTypeErrorList ki ty pt tm a i AnnotationTag = 57 | '[] 58 | type InferTypeWarningList ki ty pt tm a i AnnotationTag = 59 | '[] 60 | 61 | inferTypeInput m i _ = 62 | annotationInferTypeInput m i 63 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Annotation.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Annotation.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Annotation.Helpers ( 9 | tmAnnotation 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Type 15 | import Ast.Term 16 | 17 | import Fragment.Annotation.Ast.Term 18 | 19 | tmAnnotation :: AsTmAnnotation ki ty pt tm 20 | => Type ki ty a 21 | -> Term ki ty pt tm a 22 | -> Term ki ty pt tm a 23 | tmAnnotation = 24 | curry $ review _TmAnnotation 25 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Annotation.Rules ( 12 | RAnnotation 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Rules 19 | 20 | import Fragment.Annotation.Ast 21 | import qualified Fragment.Annotation.Rules.Type.Infer.SyntaxDirected as TSD 22 | import qualified Fragment.Annotation.Rules.Type.Infer.Offline as TUO 23 | 24 | data RAnnotation 25 | 26 | instance AstIn RAnnotation where 27 | type KindList RAnnotation = '[] 28 | type TypeList RAnnotation = '[] 29 | type PatternList RAnnotation = '[] 30 | type TermList RAnnotation = '[TmFAnnotation] 31 | 32 | instance RulesIn RAnnotation where 33 | type InferKindContextSyntax e w s r m ki ty a RAnnotation = 34 | (() :: Constraint) 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RAnnotation = 36 | TSD.AnnotationInferTypeContext e w s r m ki ty pt tm a 37 | type InferTypeContextOffline e w s r m ki ty pt tm a RAnnotation = 38 | TUO.AnnotationInferTypeContext e w s r m ki ty pt tm a 39 | type ErrorList ki ty pt tm a RAnnotation = '[] 40 | type WarningList ki ty pt tm a RAnnotation = '[] 41 | 42 | inferKindInputSyntax _ = mempty 43 | inferTypeInputSyntax _ = TSD.annotationInferTypeRules 44 | inferTypeInputOffline _ = TUO.annotationInferTypeRules 45 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Annotation.Rules.Term ( 10 | AnnotationEvalConstraint 11 | , annotationEvalRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Term 17 | import Ast.Pattern 18 | import Ast.Term 19 | 20 | import Fragment.Annotation.Ast.Term 21 | 22 | type AnnotationEvalConstraint ki ty pt tm a = AsTmAnnotation ki ty pt tm 23 | 24 | valueAnnotation :: AsTmAnnotation ki ty pt tm 25 | => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) 26 | -> Term ki ty pt tm a 27 | -> Maybe (Term ki ty pt tm a) 28 | valueAnnotation valueFn tm = do 29 | (tyA, tmA) <- preview _TmAnnotation tm 30 | vA <- valueFn tmA 31 | return $ review _TmAnnotation (tyA, vA) 32 | 33 | stepAnnotation :: AsTmAnnotation ki ty pt tm 34 | => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) 35 | -> Term ki ty pt tm a 36 | -> Maybe (Term ki ty pt tm a) 37 | stepAnnotation stepFn tm = do 38 | (tyA, tmA) <- preview _TmAnnotation tm 39 | tmA' <- stepFn tmA 40 | return $ review _TmAnnotation (tyA, tmA') 41 | 42 | matchAnnotation :: AsTmAnnotation ki ty pt tm 43 | => (Pattern pt a -> Term ki ty pt tm a -> Maybe [Term ki ty pt tm a]) 44 | -> Pattern pt a 45 | -> Term ki ty pt tm a 46 | -> Maybe [Term ki ty pt tm a] 47 | matchAnnotation matchFn pt tm = do 48 | (_, tmA) <- preview _TmAnnotation tm 49 | matchFn pt tmA 50 | 51 | annotationEvalRules :: AnnotationEvalConstraint ki ty pt tm a 52 | => EvalInput ki ty pt tm a 53 | annotationEvalRules = 54 | EvalInput 55 | [ ValueRecurse valueAnnotation ] 56 | [ StepRecurse stepAnnotation ] 57 | [ MatchRecurse matchAnnotation ] 58 | 59 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Annotation.Rules.Type.Infer.Common ( 11 | AnnotationInferTypeConstraint 12 | , annotationInferTypeInput 13 | ) where 14 | 15 | import Data.Proxy (Proxy) 16 | 17 | import Control.Lens (preview) 18 | 19 | import Ast.Type 20 | import Ast.Error.Common 21 | import Ast.Term 22 | import Rules.Type.Infer.Common 23 | 24 | import Fragment.Annotation.Ast.Term 25 | 26 | type AnnotationInferTypeConstraint e w s r m ki ty pt tm a i = 27 | ( BasicInferTypeConstraint e w s r m ki ty pt tm a i 28 | , AsTmAnnotation ki ty pt tm 29 | ) 30 | 31 | annotationInferTypeInput :: AnnotationInferTypeConstraint e w s r m ki ty pt tm a i 32 | => Proxy (MonadProxy e w s r m) 33 | -> Proxy i 34 | -> InferTypeInput e w s r m (InferTypeMonad m ki ty a i) ki ty pt tm a 35 | annotationInferTypeInput m i = 36 | InferTypeInput [] [InferTypeRecurse $ inferTmAnnotation m i ] [] 37 | 38 | inferTmAnnotation :: AnnotationInferTypeConstraint e w s r m ki ty pt tm a i 39 | => Proxy (MonadProxy e w s r m) 40 | -> Proxy i 41 | -> (Term ki ty pt tm a -> InferTypeMonad m ki ty a i (Type ki ty a)) 42 | -> Term ki ty pt tm a 43 | -> Maybe (InferTypeMonad m ki ty a i (Type ki ty a)) 44 | inferTmAnnotation m i inferFn tm = do 45 | (tyE, tmAnn) <- preview _TmAnnotation tm 46 | return $ do 47 | tyA <- inferFn tmAnn 48 | expectType m i (ExpectedType tyE) (ActualType tyA) 49 | return tyE 50 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Annotation.Rules.Type.Infer.Offline ( 11 | AnnotationInferTypeContext 12 | , annotationInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.Offline 16 | 17 | import Fragment.Annotation.Ast.Term 18 | import Fragment.Annotation.Rules.Type.Infer.Common 19 | 20 | type AnnotationInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsTmAnnotation ki ty pt tm) 21 | 22 | annotationInferTypeRules :: AnnotationInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 24 | annotationInferTypeRules = 25 | let 26 | ah = AnnotationHelper expectType 27 | in 28 | inferTypeInput ah 29 | -------------------------------------------------------------------------------- /src/Fragment/Annotation/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Annotation.Rules.Type.Infer.SyntaxDirected ( 10 | AnnotationInferTypeContext 11 | , annotationInferTypeRules 12 | ) where 13 | 14 | import Rules.Type.Infer.SyntaxDirected 15 | 16 | import Fragment.Annotation.Ast.Term 17 | import Fragment.Annotation.Rules.Type.Infer.Common 18 | 19 | type AnnotationInferTypeContext e w s r m ki ty pt tm a = AsTmAnnotation ki ty pt tm 20 | 21 | annotationInferTypeRules :: AnnotationInferTypeContext e w s r m ki ty pt tm a 22 | => InferTypeInput e w s r m m ki ty pt tm a 23 | annotationInferTypeRules = 24 | let 25 | ah = AnnotationHelper expectType 26 | in 27 | inferTypeInput ah 28 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Bool.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Bool.Ast.Type as X 13 | import Fragment.Bool.Ast.Pattern as X 14 | import Fragment.Bool.Ast.Term as X 15 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Bool.Helpers ( 9 | tyBool 10 | , ptBool 11 | , tmBool 12 | , tmAnd 13 | , tmOr 14 | ) where 15 | 16 | import Control.Lens (review) 17 | 18 | import Ast.Type 19 | import Ast.Pattern 20 | import Ast.Term 21 | 22 | import Fragment.Bool.Ast.Type 23 | import Fragment.Bool.Ast.Pattern 24 | import Fragment.Bool.Ast.Term 25 | 26 | tyBool :: AsTyBool ki ty => Type ki ty a 27 | tyBool = review _TyBool () 28 | 29 | ptBool :: AsPtBool pt => Bool -> Pattern pt a 30 | ptBool = review _PtBool 31 | 32 | tmBool :: AsTmBool ki ty pt tm => Bool -> Term ki ty pt tm a 33 | tmBool = review _TmBool 34 | 35 | tmAnd :: AsTmBool ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 36 | tmAnd = curry $ review _TmAnd 37 | 38 | tmOr :: AsTmBool ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 39 | tmOr = curry $ review _TmOr 40 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Bool.Rules ( 12 | RBool 13 | ) where 14 | 15 | import Ast 16 | import Rules 17 | import Ast.Error.Common 18 | 19 | import Fragment.KiBase.Ast.Kind 20 | 21 | import Fragment.Bool.Ast 22 | import qualified Fragment.Bool.Rules.Kind.Infer.SyntaxDirected as KSD 23 | import qualified Fragment.Bool.Rules.Type.Infer.SyntaxDirected as TSD 24 | import qualified Fragment.Bool.Rules.Type.Infer.Offline as TUO 25 | 26 | data RBool 27 | 28 | instance AstIn RBool where 29 | type KindList RBool = '[KiFBase] 30 | type TypeList RBool = '[TyFBool] 31 | type PatternList RBool = '[PtFBool] 32 | type TermList RBool = '[TmFBool] 33 | 34 | instance RulesIn RBool where 35 | type InferKindContextSyntax e w s r m ki ty a RBool = KSD.BoolInferKindContext e w s r m ki ty a 36 | type InferTypeContextSyntax e w s r m ki ty pt tm a RBool = TSD.BoolInferTypeContext e w s r m ki ty pt tm a 37 | type InferTypeContextOffline e w s r m ki ty pt tm a RBool = TUO.BoolInferTypeContext e w s r m ki ty pt tm a 38 | type ErrorList ki ty pt tm a RBool = '[ErrUnexpectedType ki ty a] 39 | type WarningList ki ty pt tm a RBool = '[] 40 | 41 | inferKindInputSyntax _ = KSD.boolInferKindRules 42 | inferTypeInputSyntax _ = TSD.boolInferTypeRules 43 | inferTypeInputOffline _ = TUO.boolInferTypeRules 44 | 45 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.Bool.Rules.Kind.Infer.Common ( 13 | BoolInferKindConstraint 14 | , boolInferKindInput 15 | ) where 16 | 17 | import Data.Proxy (Proxy(..)) 18 | 19 | import Control.Lens (review, preview) 20 | 21 | import Ast.Kind 22 | import Ast.Type 23 | import Rules.Kind.Infer.Common 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Bool.Ast.Type 27 | 28 | type BoolInferKindConstraint e w s r m ki ty a i = 29 | ( BasicInferKindConstraint e w s r m ki ty a i 30 | , AsKiBase ki 31 | , AsTyBool ki ty 32 | ) 33 | 34 | boolInferKindInput :: BoolInferKindConstraint e w s r m ki ty a i 35 | => Proxy (MonadProxy e w s r m) 36 | -> Proxy i 37 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 38 | boolInferKindInput m i = 39 | InferKindInput 40 | [] 41 | [ InferKindBase $ inferTyBool m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 42 | 43 | inferTyBool :: BoolInferKindConstraint e w s r m ki ty a i 44 | => Proxy (MonadProxy e w s r m) 45 | -> Proxy ki 46 | -> Proxy ty 47 | -> Proxy a 48 | -> Proxy i 49 | -> Type ki ty a 50 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 51 | inferTyBool pm pki pty pa pi ty = do 52 | _ <- preview _TyBool ty 53 | return . return . review _KiBase $ () 54 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Bool.Rules.Kind.Infer.SyntaxDirected ( 10 | BoolInferKindContext 11 | , boolInferKindRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Ast.Kind 17 | import Ast.Type 18 | import Rules.Kind.Infer.SyntaxDirected 19 | 20 | import Fragment.KiBase.Ast.Kind 21 | import Fragment.Bool.Ast.Type 22 | 23 | inferTyBool :: (Monad m, AsKiBase ki, AsTyBool ki ty) 24 | => Type ki ty a 25 | -> Maybe (m (Kind ki)) 26 | inferTyBool ty = do 27 | _ <- preview _TyBool ty 28 | return . return . review _KiBase $ () 29 | 30 | type BoolInferKindContext e w s r m ki ty a = (Monad m, AsKiBase ki, AsTyBool ki ty) 31 | 32 | boolInferKindRules :: BoolInferKindContext e w s r m ki ty a 33 | => InferKindInput e w s r m ki ty a 34 | boolInferKindRules = 35 | InferKindInput 36 | [InferKindBase inferTyBool] 37 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Bool.Rules.Type ( 10 | BoolNormalizeConstraint 11 | , boolNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.Bool.Ast.Type 20 | 21 | type BoolNormalizeConstraint ki ty a = AsTyBool ki ty 22 | 23 | normalizeBool :: BoolNormalizeConstraint ki ty a 24 | => Type ki ty a 25 | -> Maybe (Type ki ty a) 26 | normalizeBool ty = do 27 | _ <- preview _TyBool ty 28 | return ty 29 | 30 | boolNormalizeRules :: BoolNormalizeConstraint ki ty a 31 | => NormalizeInput ki ty a 32 | boolNormalizeRules = 33 | NormalizeInput [ NormalizeTypeBase normalizeBool ] 34 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Bool.Rules.Type.Infer.Offline ( 11 | BoolInferTypeContext 12 | , boolInferTypeRules 13 | ) where 14 | 15 | import Control.Monad.State (MonadState) 16 | import Control.Lens (review) 17 | 18 | import Rules.Type.Infer.Offline 19 | import Ast.Type 20 | import Ast.Type.Var 21 | 22 | import Fragment.Bool.Ast.Type 23 | import Fragment.Bool.Ast.Pattern 24 | import Fragment.Bool.Ast.Term 25 | 26 | import Fragment.Bool.Rules.Type.Infer.Common 27 | 28 | createBool :: (MonadState s m, HasTyVarSupply s, ToTyVar a) 29 | => m (Type ki ty a) 30 | createBool = 31 | fmap (review _TyVar) freshTyVar 32 | 33 | type BoolInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, MonadState s m, HasTyVarSupply s, ToTyVar a, AsTyBool ki ty, AsPtBool pt, AsTmBool ki ty pt tm) 34 | 35 | boolInferTypeRules :: BoolInferTypeContext e w s r m ki ty pt tm a 36 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 37 | boolInferTypeRules = 38 | let 39 | bh = BoolHelper createBool expectType 40 | in 41 | inferTypeInput bh 42 | -------------------------------------------------------------------------------- /src/Fragment/Bool/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Bool.Rules.Type.Infer.SyntaxDirected ( 10 | BoolInferTypeContext 11 | , boolInferTypeRules 12 | ) where 13 | 14 | import Control.Lens (review) 15 | 16 | import Rules.Type.Infer.SyntaxDirected 17 | import Ast.Type 18 | 19 | import Fragment.Bool.Ast.Type 20 | import Fragment.Bool.Ast.Pattern 21 | import Fragment.Bool.Ast.Term 22 | 23 | import Fragment.Bool.Rules.Type.Infer.Common 24 | 25 | createBool :: (AsTyBool ki ty, Monad m) 26 | => m (Type ki ty a) 27 | createBool = 28 | return . review _TyBool $ () 29 | 30 | type BoolInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsTyBool ki ty, AsPtBool pt, AsTmBool ki ty pt tm) 31 | 32 | boolInferTypeRules :: BoolInferTypeContext e w s r m ki ty pt tm a 33 | => InferTypeInput e w s r m m ki ty pt tm a 34 | boolInferTypeRules = 35 | let 36 | bh = BoolHelper createBool expectType 37 | in 38 | inferTypeInput bh 39 | -------------------------------------------------------------------------------- /src/Fragment/Case/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Case.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Case.Ast.Error as X 13 | import Fragment.Case.Ast.Warning as X 14 | import Fragment.Case.Ast.Term as X 15 | -------------------------------------------------------------------------------- /src/Fragment/Case/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Case.Helpers ( 9 | tmAlt 10 | , tmCase 11 | ) where 12 | 13 | import Data.Foldable (toList) 14 | import Data.List (elemIndex) 15 | 16 | import Bound (abstract) 17 | import Control.Lens (review) 18 | import Control.Lens.Wrapped (_Unwrapped) 19 | 20 | import qualified Data.List.NonEmpty as N 21 | 22 | import Ast.Pattern 23 | import Ast.Term 24 | 25 | import Fragment.Case.Ast.Term 26 | 27 | tmAlt :: (Eq a, TmAstBound ki ty pt tm, TmAstTransversable ki ty pt tm) => Pattern pt a -> Term ki ty pt tm a -> Alt ki ty pt (TmAst ki ty pt tm) (TmAstVar a) 28 | tmAlt p tm = Alt (review _TmPattern p) s 29 | where 30 | vs = fmap TmAstTmVar . toList $ p 31 | s = abstract (`elemIndex` vs) . review _Unwrapped $ tm 32 | 33 | tmCase :: AsTmCase ki ty pt tm => Term ki ty pt tm a -> [Alt ki ty pt (TmAst ki ty pt tm) (TmAstVar a)] -> Term ki ty pt tm a 34 | tmCase tm alts = 35 | case N.nonEmpty alts of 36 | Nothing -> tm 37 | Just xs -> review _TmCase (tm, xs) 38 | -------------------------------------------------------------------------------- /src/Fragment/Case/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Case.Rules ( 12 | RCase 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Rules 19 | import Ast.Error.Common 20 | import Context.Term.Error 21 | 22 | import Fragment.Case.Ast 23 | import qualified Fragment.Case.Rules.Type.Infer.SyntaxDirected as SD 24 | import qualified Fragment.Case.Rules.Type.Infer.Offline as UO 25 | 26 | data RCase 27 | 28 | instance AstIn RCase where 29 | type KindList RCase = '[] 30 | type TypeList RCase = '[] 31 | type PatternList RCase = '[] 32 | type TermList RCase = '[TmFCase] 33 | 34 | instance RulesIn RCase where 35 | type InferKindContextSyntax e w s r m ki ty a RCase = (() :: Constraint) 36 | type InferTypeContextSyntax e w s r m ki ty pt tm a RCase = SD.CaseInferTypeContext e w s r m ki ty pt tm a 37 | type InferTypeContextOffline e w s r m ki ty pt tm a RCase = UO.CaseInferTypeContext e w s r m ki ty pt tm a 38 | type ErrorList ki ty pt tm a RCase = '[ErrExpectedTypeAllEq ki ty a, ErrUnboundTermVariable a, ErrExpectedPattern ki ty pt tm a, ErrDuplicatedPatternVariables a] 39 | type WarningList ki ty pt tm a RCase = '[WarnUnusedPatternVariables a, WarnShadowingPatternVariables a] 40 | 41 | inferKindInputSyntax _ = mempty 42 | inferTypeInputSyntax _ = SD.caseInferTypeRules 43 | inferTypeInputOffline _ = UO.caseInferTypeRules 44 | -------------------------------------------------------------------------------- /src/Fragment/Case/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Case.Rules.Type.Infer.Offline ( 12 | CaseInferTypeContext 13 | , caseInferTypeRules 14 | ) where 15 | 16 | import Control.Monad.Trans (lift) 17 | 18 | import Rules.Type.Infer.Offline 19 | 20 | import qualified Fragment.Case.Rules.Type.Infer.Common as C 21 | 22 | type CaseInferTypeContext e w s r m ki ty pt tm a = C.CaseInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 23 | 24 | caseInferTypeRules :: CaseInferTypeContext e w s r m ki ty pt tm a 25 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 26 | caseInferTypeRules = 27 | let 28 | ch = C.CaseHelper lift expectTypeAllEq 29 | in 30 | C.inferTypeInput ch 31 | -------------------------------------------------------------------------------- /src/Fragment/Case/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Case.Rules.Type.Infer.SyntaxDirected ( 12 | CaseInferTypeContext 13 | , caseInferTypeRules 14 | ) where 15 | 16 | import Ast.Error.Common 17 | import Rules.Type.Infer.SyntaxDirected 18 | 19 | import qualified Fragment.Case.Rules.Type.Infer.Common as C 20 | 21 | type CaseInferTypeContext e w s r m ki ty pt tm a = 22 | (C.CaseInferTypeContext e w s r m m ki ty pt tm a, AsExpectedTypeAllEq e ki ty a) 23 | 24 | caseInferTypeRules :: CaseInferTypeContext e w s r m ki ty pt tm a 25 | => InferTypeInput e w s r m m ki ty pt tm a 26 | caseInferTypeRules = 27 | let 28 | ch = C.CaseHelper id expectTypeAllEq 29 | in 30 | C.inferTypeInput ch 31 | -------------------------------------------------------------------------------- /src/Fragment/Fix.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.Fix ( 13 | module X 14 | , FixTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | 24 | import Fragment.Fix.Ast as X 25 | import Fragment.Fix.Helpers as X 26 | 27 | import Fragment.TyArr.Ast.Type 28 | import Fragment.TyArr.Ast.Error 29 | import Fragment.TmLam.Ast.Term 30 | 31 | import Fragment.Fix.Rules.Term 32 | import Fragment.Fix.Rules.Type.Infer.Common 33 | 34 | data FixTag 35 | 36 | instance AstIn FixTag where 37 | type KindList FixTag = '[] 38 | type TypeList FixTag = '[TyFArr] 39 | type TypeSchemeList FixTag = '[] 40 | type PatternList FixTag = '[] 41 | type TermList FixTag = '[TmFFix, TmFLam] 42 | 43 | instance EvalRules e FixTag where 44 | type EvalConstraint ki ty pt tm a e FixTag = 45 | FixEvalConstraint ki ty pt tm a 46 | 47 | evalInput _ _ = 48 | fixEvalRules 49 | 50 | instance NormalizeRules FixTag where 51 | type NormalizeConstraint ki ty a FixTag = 52 | (() :: Constraint) 53 | 54 | normalizeInput _ = 55 | mempty 56 | 57 | instance MkInferType i => InferTypeRules i FixTag where 58 | type InferTypeConstraint e w s r m ki ty pt tm a i FixTag = 59 | FixInferTypeConstraint e w s r m ki ty pt tm a i 60 | type InferTypeErrorList ki ty pt tm a i FixTag = 61 | '[ ErrExpectedTyArr ki ty a ] 62 | type InferTypeWarningList ki ty pt tm a i FixTag = 63 | '[] 64 | 65 | inferTypeInput m i _ = 66 | fixInferTypeInput m i 67 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Fix.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Fix.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Fix.Helpers ( 9 | tmFix 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Term 15 | 16 | import Fragment.Fix.Ast.Term 17 | 18 | tmFix :: AsTmFix ki ty pt tm 19 | => Term ki ty pt tm a 20 | -> Term ki ty pt tm a 21 | tmFix = review _TmFix 22 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Fix.Rules ( 12 | RFix 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Error.Common 19 | import Rules 20 | 21 | import Fragment.TyArr.Ast.Error 22 | import Fragment.TyArr.Ast.Type 23 | 24 | import Fragment.Fix.Ast 25 | import qualified Fragment.Fix.Rules.Type.Infer.SyntaxDirected as TSD 26 | import qualified Fragment.Fix.Rules.Type.Infer.Offline as TUO 27 | 28 | data RFix 29 | 30 | instance AstIn RFix where 31 | type KindList RFix = '[] 32 | type TypeList RFix = '[TyFArr] 33 | type PatternList RFix = '[] 34 | type TermList RFix = '[TmFFix] 35 | 36 | instance RulesIn RFix where 37 | type InferKindContextSyntax e w s r m ki ty a RFix = 38 | (() :: Constraint) 39 | type InferTypeContextSyntax e w s r m ki ty pt tm a RFix = 40 | TSD.FixInferTypeContext e w s r m ki ty pt tm a 41 | type InferTypeContextOffline e w s r m ki ty pt tm a RFix = 42 | TUO.FixInferTypeContext e w s r m ki ty pt tm a 43 | type ErrorList ki ty pt tm a RFix = '[ErrExpectedTyArr ki ty a, ErrExpectedTypeEq ki ty a] 44 | type WarningList ki ty pt tm a RFix = '[] 45 | 46 | inferKindInputSyntax _ = mempty 47 | inferTypeInputSyntax _ = TSD.fixInferTypeRules 48 | inferTypeInputOffline _ = TUO.fixInferTypeRules 49 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Fix.Rules.Term ( 10 | FixEvalConstraint 11 | , fixEvalRules 12 | ) where 13 | 14 | import Bound (instantiate1) 15 | import Control.Lens (review, preview) 16 | import Control.Lens.Wrapped (_Wrapped, _Unwrapped) 17 | 18 | import Ast.Term 19 | import Rules.Term 20 | 21 | import Fragment.TmLam.Ast.Term 22 | import Fragment.Fix.Ast.Term 23 | 24 | stepTmFix1 :: (AsTmFix ki ty pt tm) 25 | => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) 26 | -> Term ki ty pt tm a 27 | -> Maybe (Term ki ty pt tm a) 28 | stepTmFix1 stepFn tm = do 29 | tmF <- preview _TmFix tm 30 | tmF' <- stepFn tmF 31 | return $ review _TmFix tmF' 32 | 33 | stepTmFixBeta :: (AsTmFix ki ty pt tm, AsTmLam ki ty pt tm) 34 | => Term ki ty pt tm a 35 | -> Maybe (Term ki ty pt tm a) 36 | stepTmFixBeta tm = do 37 | tmF <- preview _TmFix tm 38 | (_, s) <- preview _TmLam tmF 39 | return . review _Wrapped . instantiate1 (review _Unwrapped tm) $ s 40 | 41 | type FixEvalConstraint ki ty pt tm a = 42 | ( AsTmFix ki ty pt tm 43 | , AsTmLam ki ty pt tm 44 | ) 45 | 46 | fixEvalRules :: FixEvalConstraint ki ty pt tm a 47 | => EvalInput ki ty pt tm a 48 | fixEvalRules = 49 | EvalInput 50 | [] 51 | [ StepRecurse stepTmFix1 52 | , StepBase stepTmFixBeta 53 | ] 54 | [] 55 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Fix.Rules.Type.Infer.Offline ( 11 | FixInferTypeContext 12 | , fixInferTypeRules 13 | ) where 14 | 15 | import Control.Lens (review) 16 | import Control.Monad.State (MonadState) 17 | 18 | import Ast.Type 19 | import Ast.Type.Var 20 | import Data.Functor.Rec 21 | import Rules.Type.Infer.Offline 22 | 23 | import Fragment.TyArr.Ast.Type 24 | 25 | import qualified Fragment.Fix.Rules.Type.Infer.Common as F 26 | 27 | expectTyArr :: (Eq a, EqRec (ty ki), MonadState s m, HasTyVarSupply s, ToTyVar a, AsTyArr ki ty) 28 | => Type ki ty a 29 | -> UnifyT ki ty a m (Type ki ty a, Type ki ty a) 30 | expectTyArr ty = do 31 | tyArg <- fmap (review _TyVar) freshTyVar 32 | tyRet <- fmap (review _TyVar) freshTyVar 33 | let tyArr = review _TyArr (tyArg, tyRet) 34 | expectTypeEq ty tyArr 35 | return (tyArg, tyRet) 36 | 37 | type FixInferTypeContext e w s r m ki ty pt tm a = 38 | ( F.FixInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 39 | , Eq a 40 | , EqRec (ty ki) 41 | , MonadState s m 42 | , HasTyVarSupply s 43 | , ToTyVar a 44 | ) 45 | 46 | fixInferTypeRules :: FixInferTypeContext e w s r m ki ty pt tm a 47 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 48 | fixInferTypeRules = 49 | let 50 | fh = F.FixHelper expectTyArr expectTypeEq 51 | in 52 | F.inferTypeInput fh 53 | -------------------------------------------------------------------------------- /src/Fragment/Fix/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Fix.Rules.Type.Infer.SyntaxDirected ( 10 | FixInferTypeContext 11 | , fixInferTypeRules 12 | ) where 13 | 14 | import Control.Monad.Except (MonadError) 15 | 16 | import Ast.Error.Common 17 | import Data.Functor.Rec 18 | import Rules.Type.Infer.SyntaxDirected 19 | 20 | import Fragment.TyArr.Ast.Error 21 | 22 | import qualified Fragment.Fix.Rules.Type.Infer.Common as F 23 | 24 | type FixInferTypeContext e w s r m ki ty pt tm a = 25 | ( F.FixInferTypeContext e w s r m m ki ty pt tm a 26 | , Eq a 27 | , EqRec (ty ki) 28 | , MonadError e m 29 | , AsExpectedTyArr e ki ty a 30 | , AsExpectedTypeEq e ki ty a 31 | ) 32 | 33 | fixInferTypeRules :: FixInferTypeContext e w s r m ki ty pt tm a 34 | => InferTypeInput e w s r m m ki ty pt tm a 35 | fixInferTypeRules = 36 | let 37 | fh = F.FixHelper expectTyArr expectTypeEq 38 | in 39 | F.inferTypeInput fh 40 | -------------------------------------------------------------------------------- /src/Fragment/HM.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.HM ( 9 | module X 10 | ) where 11 | 12 | import Fragment.HM.Ast as X 13 | import Fragment.HM.Rules as X 14 | import Fragment.HM.Helpers as X 15 | -------------------------------------------------------------------------------- /src/Fragment/If.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.If ( 13 | module X 14 | , IfTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | import Fragment.Bool.Ast 24 | 25 | import Fragment.If.Ast as X 26 | import Fragment.If.Helpers as X 27 | 28 | import Fragment.If.Rules.Type.Infer.Common 29 | import Fragment.If.Rules.Term 30 | 31 | data IfTag 32 | 33 | instance AstIn IfTag where 34 | type KindList IfTag = '[] 35 | type TypeList IfTag = '[TyFBool] 36 | type TypeSchemeList IfTag = '[] 37 | type PatternList IfTag = '[] 38 | type TermList IfTag = '[TmFBool, TmFIf] 39 | 40 | instance EvalRules e IfTag where 41 | type EvalConstraint ki ty pt tm a e IfTag = 42 | IfEvalConstraint ki ty pt tm a 43 | 44 | evalInput _ _ = 45 | ifEvalRules 46 | 47 | instance NormalizeRules IfTag where 48 | type NormalizeConstraint ki ty a IfTag = 49 | (() :: Constraint) 50 | 51 | normalizeInput _ = 52 | mempty 53 | 54 | instance MkInferType i => InferTypeRules i IfTag where 55 | type InferTypeConstraint e w s r m ki ty pt tm a i IfTag = 56 | IfInferTypeConstraint e w s r m ki ty pt tm a i 57 | type InferTypeErrorList ki ty pt tm a i IfTag = 58 | '[] 59 | type InferTypeWarningList ki ty pt tm a i IfTag = 60 | '[] 61 | 62 | inferTypeInput m i _ = 63 | ifInferTypeInput m i 64 | -------------------------------------------------------------------------------- /src/Fragment/If/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.If.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.If.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/If/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.If.Helpers ( 9 | tmIf 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Term 15 | 16 | import Fragment.If.Ast.Term 17 | 18 | tmIf :: AsTmIf ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 19 | tmIf b t f = review _TmIf (b, t, f) 20 | -------------------------------------------------------------------------------- /src/Fragment/If/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.If.Rules ( 12 | RIf 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Error.Common 19 | import Rules 20 | 21 | import Fragment.Bool.Ast.Type 22 | import Fragment.Bool.Ast.Term 23 | 24 | import Fragment.If.Ast 25 | import qualified Fragment.If.Rules.Type.Infer.SyntaxDirected as SD 26 | import qualified Fragment.If.Rules.Type.Infer.Offline as UO 27 | 28 | data RIf 29 | 30 | instance AstIn RIf where 31 | type KindList RIf = '[] 32 | type TypeList RIf = '[TyFBool] 33 | type PatternList RIf = '[] 34 | type TermList RIf = '[TmFBool, TmFIf] 35 | 36 | instance RulesIn RIf where 37 | type InferKindContextSyntax e w s r m ki ty a RIf = (() :: Constraint) 38 | type InferTypeContextSyntax e w s r m ki ty pt tm a RIf = SD.IfInferTypeContext e w s r m ki ty pt tm a 39 | type InferTypeContextOffline e w s r m ki ty pt tm a RIf = UO.IfInferTypeContext e w s r m ki ty pt tm a 40 | type ErrorList ki ty pt tm a RIf = '[ErrUnexpectedType ki ty a, ErrExpectedTypeEq ki ty a] 41 | type WarningList ki ty pt tm a RIf = '[] 42 | 43 | inferKindInputSyntax _ = mempty 44 | inferTypeInputSyntax _ = SD.ifInferTypeRules 45 | inferTypeInputOffline _ = UO.ifInferTypeRules 46 | -------------------------------------------------------------------------------- /src/Fragment/If/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.If.Rules.Term ( 10 | IfEvalConstraint 11 | , ifEvalRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Term 17 | import Ast.Term 18 | 19 | import Fragment.Bool.Ast.Term 20 | import Fragment.If.Ast.Term 21 | 22 | stepIf1 :: AsTmIf ki ty pt tm => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 23 | stepIf1 stepFn tm = do 24 | (tmB, tmT, tmE) <- preview _TmIf tm 25 | tmB' <- stepFn tmB 26 | return $ review _TmIf (tmB', tmT, tmE) 27 | 28 | stepIf2 :: (AsTmIf ki ty pt tm, AsTmBool ki ty pt tm) => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 29 | stepIf2 valueFn tm = do 30 | (tmB, tmT, tmF) <- preview _TmIf tm 31 | vB <- valueFn tmB 32 | b <- preview _TmBool vB 33 | return $ 34 | if b then tmT else tmF 35 | 36 | type IfEvalConstraint ki ty pt tm a = 37 | ( AsTmBool ki ty pt tm 38 | , AsTmIf ki ty pt tm 39 | ) 40 | 41 | ifEvalRules :: IfEvalConstraint ki ty pt tm a 42 | => EvalInput ki ty pt tm a 43 | ifEvalRules = 44 | EvalInput [] [ StepRecurse stepIf1, StepValue stepIf2] [] 45 | -------------------------------------------------------------------------------- /src/Fragment/If/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.If.Rules.Type.Infer.Common ( 11 | IfInferTypeConstraint 12 | , ifInferTypeInput 13 | ) where 14 | 15 | import Data.Proxy (Proxy(..)) 16 | 17 | import Control.Lens (review, preview) 18 | 19 | import Ast.Type 20 | import Ast.Error.Common 21 | import Ast.Term 22 | 23 | import Fragment.Bool.Ast.Type 24 | import Fragment.If.Ast.Term 25 | 26 | import Rules.Type.Infer.Common 27 | 28 | type IfInferTypeConstraint e w s r m ki ty pt tm a i = 29 | ( BasicInferTypeConstraint e w s r m ki ty pt tm a i 30 | , AsTmIf ki ty pt tm 31 | , AsTyBool ki ty 32 | ) 33 | 34 | ifInferTypeInput :: IfInferTypeConstraint e w s r m ki ty pt tm a i 35 | => Proxy (MonadProxy e w s r m) 36 | -> Proxy i 37 | -> InferTypeInput e w s r m (InferTypeMonad m ki ty a i) ki ty pt tm a 38 | ifInferTypeInput m i = 39 | InferTypeInput 40 | [] [ InferTypeRecurse $ inferTmIf m i ] [] 41 | 42 | inferTmIf :: IfInferTypeConstraint e w s r m ki ty pt tm a i 43 | => Proxy (MonadProxy e w s r m) 44 | -> Proxy i 45 | -> (Term ki ty pt tm a -> InferTypeMonad m ki ty a i (Type ki ty a)) 46 | -> Term ki ty pt tm a 47 | -> Maybe (InferTypeMonad m ki ty a i (Type ki ty a)) 48 | inferTmIf m i inferFn tm = do 49 | (tmB, tmT, tmF) <- preview _TmIf tm 50 | return $ do 51 | tyB <- inferFn tmB 52 | expectType m i (ExpectedType tyB) (ActualType (review _TyBool ())) 53 | tyT <- inferFn tmT 54 | tyF <- inferFn tmF 55 | expectTypeEq m i tyT tyF 56 | return tyT 57 | -------------------------------------------------------------------------------- /src/Fragment/If/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.If.Rules.Type.Infer.Offline ( 11 | IfInferTypeContext 12 | , ifInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.Offline 16 | import Ast.Error.Common 17 | 18 | import Fragment.Bool.Ast.Type 19 | import Fragment.If.Ast.Term 20 | 21 | import Fragment.If.Rules.Type.Infer.Common 22 | 23 | type IfInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsUnexpectedType e ki ty a, AsExpectedTypeEq e ki ty a, AsTyBool ki ty, AsTmIf ki ty pt tm) 24 | 25 | ifInferTypeRules :: IfInferTypeContext e w s r m ki ty pt tm a 26 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 27 | ifInferTypeRules = 28 | let 29 | ih = IfHelper expectType expectTypeEq 30 | in 31 | inferTypeInput ih 32 | -------------------------------------------------------------------------------- /src/Fragment/If/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.If.Rules.Type.Infer.SyntaxDirected ( 10 | IfInferTypeContext 11 | , ifInferTypeRules 12 | ) where 13 | 14 | import Rules.Type.Infer.SyntaxDirected 15 | import Ast.Error.Common 16 | 17 | import Fragment.Bool.Ast.Type 18 | import Fragment.If.Ast.Term 19 | 20 | import Fragment.If.Rules.Type.Infer.Common 21 | 22 | type IfInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsUnexpectedType e ki ty a, AsExpectedTypeEq e ki ty a, AsTyBool ki ty, AsTmIf ki ty pt tm) 23 | 24 | ifInferTypeRules :: IfInferTypeContext e w s r m ki ty pt tm a 25 | => InferTypeInput e w s r m m ki ty pt tm a 26 | ifInferTypeRules = 27 | let 28 | ih = IfHelper expectType expectTypeEq 29 | in 30 | inferTypeInput ih 31 | -------------------------------------------------------------------------------- /src/Fragment/Int/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Int.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Int.Ast.Type as X 13 | import Fragment.Int.Ast.Pattern as X 14 | import Fragment.Int.Ast.Term as X 15 | -------------------------------------------------------------------------------- /src/Fragment/Int/Ast/Pattern.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE DeriveFunctor #-} 9 | {-# LANGUAGE DeriveFoldable #-} 10 | {-# LANGUAGE DeriveTraversable #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE KindSignatures #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE DataKinds #-} 16 | {-# LANGUAGE TemplateHaskell #-} 17 | module Fragment.Int.Ast.Pattern ( 18 | PtFInt 19 | , AsPtInt(..) 20 | ) where 21 | 22 | import Bound (Bound(..)) 23 | import Control.Lens.Prism (Prism') 24 | import Control.Lens.TH (makePrisms) 25 | import Data.Deriving (deriveEq1, deriveOrd1, deriveShow1) 26 | 27 | import Ast.Pattern 28 | import Data.Bitransversable 29 | import Data.Functor.Rec 30 | 31 | data PtFInt (f :: * -> *) a = 32 | PtIntF Int 33 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 34 | 35 | makePrisms ''PtFInt 36 | 37 | deriveEq1 ''PtFInt 38 | deriveOrd1 ''PtFInt 39 | deriveShow1 ''PtFInt 40 | 41 | instance EqRec PtFInt where 42 | liftEqRec _ _ (PtIntF i) (PtIntF j) = i == j 43 | 44 | instance OrdRec PtFInt where 45 | liftCompareRec _ _ (PtIntF i) (PtIntF j) = compare i j 46 | 47 | instance ShowRec PtFInt where 48 | liftShowsPrecRec _ _ _ _ = showsPrec 49 | 50 | instance Bound PtFInt where 51 | PtIntF i >>>= _ = PtIntF i 52 | 53 | instance Bitransversable PtFInt where 54 | bitransverse _ _ (PtIntF i) = pure $ PtIntF i 55 | 56 | class AsPtInt pt where 57 | _PtIntP :: Prism' (pt k a) (PtFInt k a) 58 | 59 | _PtInt :: Prism' (Pattern pt a) Int 60 | _PtInt = _PtTree . _PtIntP . _PtIntF 61 | 62 | instance AsPtInt PtFInt where 63 | _PtIntP = id 64 | 65 | instance {-# OVERLAPPABLE #-} AsPtInt (PtSum xs) => AsPtInt (PtSum (x ': xs)) where 66 | _PtIntP = _PtNext . _PtIntP 67 | 68 | instance {-# OVERLAPPING #-} AsPtInt (PtSum (PtFInt ': xs)) where 69 | _PtIntP = _PtNow . _PtIntP 70 | -------------------------------------------------------------------------------- /src/Fragment/Int/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Int.Helpers ( 9 | tyInt 10 | , ptInt 11 | , tmInt 12 | , tmAdd 13 | , tmSub 14 | , tmMul 15 | ) where 16 | 17 | import Control.Lens (review) 18 | 19 | import Ast.Type 20 | import Ast.Pattern 21 | import Ast.Term 22 | 23 | import Fragment.Int.Ast.Type 24 | import Fragment.Int.Ast.Pattern 25 | import Fragment.Int.Ast.Term 26 | 27 | tyInt :: AsTyInt ki ty => Type ki ty a 28 | tyInt = review _TyInt () 29 | 30 | ptInt :: AsPtInt pt => Int -> Pattern pt a 31 | ptInt = review _PtInt 32 | 33 | tmInt :: AsTmInt ki ty pt tm => Int -> Term ki ty pt tm a 34 | tmInt = review _TmInt 35 | 36 | tmAdd :: AsTmInt ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 37 | tmAdd = curry $ review _TmAdd 38 | 39 | tmSub :: AsTmInt ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 40 | tmSub = curry $ review _TmSub 41 | 42 | tmMul :: AsTmInt ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 43 | tmMul = curry $ review _TmMul 44 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Int.Rules ( 12 | RInt 13 | ) where 14 | 15 | import Ast 16 | import Ast.Error.Common 17 | import Rules 18 | 19 | import Fragment.KiBase.Ast.Kind 20 | 21 | import Fragment.Int.Ast 22 | import qualified Fragment.Int.Rules.Kind.Infer.SyntaxDirected as KSD 23 | import qualified Fragment.Int.Rules.Type.Infer.SyntaxDirected as TSD 24 | import qualified Fragment.Int.Rules.Type.Infer.Offline as TUO 25 | 26 | data RInt 27 | 28 | instance AstIn RInt where 29 | type KindList RInt = '[KiFBase] 30 | type TypeList RInt = '[TyFInt] 31 | type PatternList RInt = '[PtFInt] 32 | type TermList RInt = '[TmFInt] 33 | 34 | instance RulesIn RInt where 35 | type InferKindContextSyntax e w s r m ki ty a RInt = KSD.IntInferKindContext e w s r m ki ty a 36 | type InferTypeContextSyntax e w s r m ki ty pt tm a RInt = TSD.IntInferTypeContext e w s r m ki ty pt tm a 37 | type InferTypeContextOffline e w s r m ki ty pt tm a RInt = TUO.IntInferTypeContext e w s r m ki ty pt tm a 38 | type ErrorList ki ty pt tm a RInt = '[ErrUnexpectedType ki ty a] 39 | type WarningList ki ty pt tm a RInt = '[] 40 | 41 | inferKindInputSyntax _ = KSD.intInferKindRules 42 | inferTypeInputSyntax _ = TSD.intInferTypeRules 43 | inferTypeInputOffline _ = TUO.intInferTypeRules 44 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.Int.Rules.Kind.Infer.Common ( 13 | IntInferKindConstraint 14 | , intInferKindInput 15 | ) where 16 | 17 | import Data.Proxy (Proxy(..)) 18 | 19 | import Control.Lens (review, preview) 20 | 21 | import Ast.Kind 22 | import Ast.Type 23 | import Rules.Kind.Infer.Common 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Int.Ast.Type 27 | 28 | type IntInferKindConstraint e w s r m ki ty a i = 29 | ( BasicInferKindConstraint e w s r m ki ty a i 30 | , AsKiBase ki 31 | , AsTyInt ki ty 32 | ) 33 | 34 | intInferKindInput :: IntInferKindConstraint e w s r m ki ty a i 35 | => Proxy (MonadProxy e w s r m) 36 | -> Proxy i 37 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 38 | intInferKindInput m i = 39 | InferKindInput 40 | [] 41 | [ InferKindBase $ inferTyInt m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 42 | 43 | inferTyInt :: IntInferKindConstraint e w s r m ki ty a i 44 | => Proxy (MonadProxy e w s r m) 45 | -> Proxy ki 46 | -> Proxy ty 47 | -> Proxy a 48 | -> Proxy i 49 | -> Type ki ty a 50 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 51 | inferTyInt pm pki pty pa pi ty = do 52 | _ <- preview _TyInt ty 53 | return . return . review _KiBase $ () 54 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Int.Rules.Kind.Infer.SyntaxDirected ( 10 | IntInferKindContext 11 | , intInferKindRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Ast.Kind 17 | import Ast.Type 18 | import Rules.Kind.Infer.SyntaxDirected 19 | 20 | import Fragment.KiBase.Ast.Kind 21 | import Fragment.Int.Ast.Type 22 | 23 | inferTyInt :: (Monad m, AsKiBase ki, AsTyInt ki ty) 24 | => Type ki ty a 25 | -> Maybe (m (Kind ki)) 26 | inferTyInt ty = do 27 | _ <- preview _TyInt ty 28 | return . return . review _KiBase $ () 29 | 30 | type IntInferKindContext e w s r m ki ty a = (Monad m, AsKiBase ki, AsTyInt ki ty) 31 | 32 | intInferKindRules :: IntInferKindContext e w s r m ki ty a 33 | => InferKindInput e w s r m ki ty a 34 | intInferKindRules = 35 | InferKindInput 36 | [InferKindBase inferTyInt] 37 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Int.Rules.Type ( 10 | IntNormalizeConstraint 11 | , intNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.Int.Ast.Type 20 | 21 | type IntNormalizeConstraint ki ty a = AsTyInt ki ty 22 | 23 | normalizeInt :: IntNormalizeConstraint ki ty a 24 | => Type ki ty a 25 | -> Maybe (Type ki ty a) 26 | normalizeInt ty = do 27 | _ <- preview _TyInt ty 28 | return ty 29 | 30 | intNormalizeRules :: IntNormalizeConstraint ki ty a 31 | => NormalizeInput ki ty a 32 | intNormalizeRules = 33 | NormalizeInput [ NormalizeTypeBase normalizeInt ] 34 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Type/Infer/Class.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE ConstraintKinds #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | module Fragment.Int.Rules.Type.Infer.Class ( 13 | IntInferTypeHelper(..) 14 | ) where 15 | 16 | import Data.Proxy (Proxy) 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast.Type 20 | import Rules.Type.Infer.Common 21 | 22 | class MkInferType i => IntInferTypeHelper i t where 23 | type IntInferTypeHelperConstraint e w s r (m :: * -> *) (ki :: * -> *) (ty :: (* -> *) -> (* -> *) -> * -> *) a i t :: Constraint 24 | 25 | createInt :: IntInferTypeHelperConstraint e w s r m ki ty a i t 26 | => Proxy (MonadProxy e w s r m) 27 | -> Proxy i 28 | -> Proxy t 29 | -> InferTypeMonad m ki ty a i (Type ki ty a) 30 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | module Fragment.Int.Rules.Type.Infer.Offline ( 13 | IOfflineInt 14 | ) where 15 | 16 | import Control.Lens (review) 17 | 18 | import Ast.Type 19 | import Ast.Type.Var 20 | 21 | import Rules.Type.Infer.Offline (IOffline) 22 | import Control.Monad.State (MonadState) 23 | 24 | import Fragment.Int.Rules.Type.Infer.Common 25 | 26 | data IOfflineInt 27 | 28 | instance IntInferTypeHelper ITOffline IOfflineInt where 29 | type IntInferTypeHelperConstraint e w s r m ki ty a ITOffline IOfflineInt = 30 | ( MonadState s m 31 | , HasTyVarSupply s 32 | , ToTyVar a 33 | ) 34 | 35 | createInt _ _ _ = 36 | fmap (review _TyVar) freshTyVar 37 | -------------------------------------------------------------------------------- /src/Fragment/Int/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Int.Rules.Type.Infer.SyntaxDirected ( 12 | ISyntaxInt 13 | ) where 14 | 15 | import Control.Lens (review) 16 | 17 | import Rules.Type.Infer.SyntaxDirected (ISyntax) 18 | 19 | import Fragment.Int.Ast.Type 20 | import Fragment.Int.Rules.Type.Infer.Common 21 | 22 | data ISyntaxInt 23 | 24 | instance IntInferTypeHelper ISyntax ISyntaxInt where 25 | type IntInferTypeHelperConstraint e w s r m ki ty a ISyntax ISyntaxInt = 26 | ( AsTyInt ki ty 27 | , Monad m 28 | ) 29 | 30 | createInt _ _ _ = 31 | return . review _TyInt $ () 32 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.IsoRec ( 13 | module X 14 | , IsoRecTag 15 | ) where 16 | 17 | import Ast 18 | import Rules.Type 19 | import Rules.Term 20 | 21 | import Fragment.IsoRec.Ast as X 22 | import Fragment.IsoRec.Rules as X 23 | import Fragment.IsoRec.Helpers as X 24 | 25 | import Fragment.IsoRec.Rules.Type 26 | import Fragment.IsoRec.Rules.Term 27 | 28 | data IsoRecTag 29 | 30 | instance AstIn IsoRecTag where 31 | type KindList IsoRecTag = '[] 32 | type TypeList IsoRecTag = '[] 33 | type PatternList IsoRecTag = '[] 34 | type TermList IsoRecTag = '[TmFIsoRec] 35 | 36 | instance EvalRules EStrict IsoRecTag where 37 | type EvalConstraint ki ty pt tm a EStrict IsoRecTag = 38 | IsoRecEvalConstraint ki ty pt tm a 39 | 40 | evalInput _ _ = 41 | isoRecEvalRulesStrict 42 | 43 | instance EvalRules ELazy IsoRecTag where 44 | type EvalConstraint ki ty pt tm a ELazy IsoRecTag = 45 | IsoRecEvalConstraint ki ty pt tm a 46 | 47 | evalInput _ _ = 48 | isoRecEvalRulesLazy 49 | 50 | instance NormalizeRules IsoRecTag where 51 | type NormalizeConstraint ki ty a IsoRecTag = 52 | IsoRecNormalizeConstraint ki ty a 53 | 54 | normalizeInput _ = 55 | isoRecNormalizeRules 56 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.IsoRec.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.IsoRec.Ast.Type as X 13 | import Fragment.IsoRec.Ast.Error as X 14 | import Fragment.IsoRec.Ast.Term as X 15 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.IsoRec.Ast.Error ( 9 | ) where 10 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.IsoRec.Helpers ( 9 | tyRec 10 | , tmFold 11 | , tmUnfold 12 | ) where 13 | 14 | import Bound (Bound) 15 | import Control.Lens (review) 16 | 17 | import Ast.Type 18 | import Ast.Term 19 | import Data.Bitransversable 20 | 21 | import Fragment.IsoRec.Ast.Type 22 | import Fragment.IsoRec.Ast.Term 23 | 24 | tyRec :: (Eq a, Bound ki, Bitransversable ki, AsTyIsoRec ki ty) 25 | => a 26 | -> Type ki ty a 27 | -> Type ki ty a 28 | tyRec v ty = review _TyRec (abstractTy v ty) 29 | 30 | tmFold :: AsTmIsoRec ki ty pt tm => Type ki ty a -> Term ki ty pt tm a -> Term ki ty pt tm a 31 | tmFold = curry $ review _TmFold 32 | 33 | tmUnfold :: AsTmIsoRec ki ty pt tm => Type ki ty a -> Term ki ty pt tm a -> Term ki ty pt tm a 34 | tmUnfold = curry $ review _TmUnfold 35 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.IsoRec.Rules ( 9 | ) where 10 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.IsoRec.Rules.Kind.Infer.SyntaxDirected ( 9 | ) where 10 | -------------------------------------------------------------------------------- /src/Fragment/IsoRec/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | module Fragment.IsoRec.Rules.Type ( 13 | IsoRecNormalizeConstraint 14 | , isoRecNormalizeRules 15 | ) where 16 | 17 | 18 | import Bound (Bound) 19 | import Control.Lens (review, preview) 20 | 21 | import Ast.Type 22 | import Data.Bitransversable 23 | import Rules.Type 24 | 25 | import Fragment.IsoRec.Ast.Type 26 | 27 | type IsoRecNormalizeConstraint ki ty a = 28 | ( AsTyIsoRec ki ty 29 | , Bound ki 30 | , Bitransversable ki 31 | ) 32 | 33 | normalizeRec :: IsoRecNormalizeConstraint ki ty a 34 | => (forall b. Type ki ty b -> Type ki ty b) 35 | -> Type ki ty a 36 | -> Maybe (Type ki ty a) 37 | normalizeRec normalizeFn ty = do 38 | s <- preview _TyRec ty 39 | return $ review _TyRec (scopeAppTy normalizeFn s) 40 | 41 | isoRecNormalizeRules :: IsoRecNormalizeConstraint ki ty a 42 | => NormalizeInput ki ty a 43 | isoRecNormalizeRules = 44 | NormalizeInput 45 | [ NormalizeTypeRecurse normalizeRec ] 46 | -------------------------------------------------------------------------------- /src/Fragment/KiArr.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.KiArr ( 13 | module X 14 | , KiArrTag 15 | ) where 16 | 17 | import Ast 18 | import Rules.Kind.Infer.Common 19 | 20 | import Fragment.KiArr.Ast as X 21 | import Fragment.KiArr.Helpers as X 22 | 23 | import Fragment.KiArr.Rules.Kind.Infer.Common 24 | 25 | data KiArrTag 26 | 27 | instance AstIn KiArrTag where 28 | type KindList KiArrTag = '[KiFArr] 29 | type TypeList KiArrTag = '[] 30 | type TypeSchemeList KiArrTag = '[] 31 | type PatternList KiArrTag = '[] 32 | type TermList KiArrTag = '[] 33 | 34 | instance MkInferKind i => InferKindRules i KiArrTag where 35 | type InferKindConstraint e w s r m ki ty a i KiArrTag = 36 | KiArrInferKindConstraint e w s r m ki ty a i 37 | type InferKindErrorList ki ty a i KiArrTag = 38 | '[] 39 | type InferKindWarningList ki ty a i KiArrTag = 40 | '[] 41 | 42 | inferKindInput m i _ = 43 | kiArrInferKindInput m i 44 | -------------------------------------------------------------------------------- /src/Fragment/KiArr/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.KiArr.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.KiArr.Ast.Kind as X 13 | import Fragment.KiArr.Ast.Error as X 14 | -------------------------------------------------------------------------------- /src/Fragment/KiArr/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Fragment.KiArr.Ast.Error ( 17 | ErrExpectedKiArr(..) 18 | , AsExpectedKiArr(..) 19 | , expectKiArr 20 | ) where 21 | 22 | import Control.Monad.Except (MonadError) 23 | import Control.Monad.Error.Lens (throwing) 24 | import Control.Lens (preview) 25 | import Control.Lens.Prism (Prism') 26 | import Control.Lens.TH (makePrisms) 27 | 28 | import Ast.Kind 29 | import Ast.Error 30 | 31 | import Fragment.KiArr.Ast.Kind 32 | 33 | data ErrExpectedKiArr ki a = ErrExpectedKiArr (Kind ki a) 34 | deriving (Eq, Ord, Show) 35 | 36 | makePrisms ''ErrExpectedKiArr 37 | 38 | class AsExpectedKiArr e ki a where -- | e -> ty, e -> a where 39 | _ExpectedKiArr :: Prism' e (Kind ki a) 40 | 41 | instance AsExpectedKiArr (ErrExpectedKiArr ki a) ki a where 42 | _ExpectedKiArr = _ErrExpectedKiArr 43 | 44 | instance {-# OVERLAPPABLE #-} AsExpectedKiArr (ErrSum xs) ki a => AsExpectedKiArr (ErrSum (x ': xs)) ki a where 45 | _ExpectedKiArr = _ErrNext . _ExpectedKiArr 46 | 47 | instance {-# OVERLAPPING #-} AsExpectedKiArr (ErrSum (ErrExpectedKiArr ki a ': xs)) ki a where 48 | _ExpectedKiArr = _ErrNow . _ExpectedKiArr 49 | 50 | expectKiArr :: (MonadError e m, AsKiArr ki, AsExpectedKiArr e ki a) => Kind ki a -> m (Kind ki a, Kind ki a) 51 | expectKiArr ty = 52 | case preview _KiArr ty of 53 | Just (tyArg, tyRet) -> return (tyArg, tyRet) 54 | _ -> throwing _ExpectedKiArr ty 55 | -------------------------------------------------------------------------------- /src/Fragment/KiArr/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.KiArr.Helpers ( 9 | kiArr 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Kind 15 | 16 | import Fragment.KiArr.Ast.Kind 17 | 18 | kiArr :: AsKiArr ki => Kind ki a -> Kind ki a -> Kind ki a 19 | kiArr = curry $ review _KiArr 20 | -------------------------------------------------------------------------------- /src/Fragment/KiBase.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.KiBase ( 9 | module X 10 | ) where 11 | 12 | import Fragment.KiBase.Ast as X 13 | import Fragment.KiBase.Helpers as X 14 | -------------------------------------------------------------------------------- /src/Fragment/KiBase/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.KiBase.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.KiBase.Ast.Kind as X 13 | -------------------------------------------------------------------------------- /src/Fragment/KiBase/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.KiBase.Helpers ( 9 | kiBase 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Kind 15 | 16 | import Fragment.KiBase.Ast.Kind 17 | 18 | kiBase :: AsKiBase k => Kind k a 19 | kiBase = review _KiBase () 20 | -------------------------------------------------------------------------------- /src/Fragment/LC.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.LC ( 13 | module X 14 | , LCTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | import Fragment.TmLam.Ast.Term 24 | import Fragment.TmApp.Ast.Term 25 | 26 | import Fragment.LC.Ast as X 27 | import Fragment.LC.Helpers as X 28 | 29 | import Fragment.LC.Rules.Term 30 | 31 | data LCTag 32 | 33 | instance AstIn LCTag where 34 | type KindList LCTag = '[] 35 | type TypeList LCTag = '[] 36 | type TypeSchemeList LCTag = '[] 37 | type PatternList LCTag = '[] 38 | type TermList LCTag = '[TmFLam, TmFApp] 39 | 40 | instance EvalRules EStrict LCTag where 41 | type EvalConstraint ki ty pt tm a EStrict LCTag = 42 | LCEvalConstraint ki ty pt tm a 43 | 44 | evalInput _ _ = 45 | lcEvalRulesStrict 46 | 47 | instance EvalRules ELazy LCTag where 48 | type EvalConstraint ki ty pt tm a ELazy LCTag = 49 | LCEvalConstraint ki ty pt tm a 50 | 51 | evalInput _ _ = 52 | lcEvalRulesLazy 53 | 54 | instance NormalizeRules LCTag where 55 | type NormalizeConstraint ki ty a LCTag = 56 | (() :: Constraint) 57 | 58 | normalizeInput _ = 59 | mempty 60 | 61 | instance MkInferType i => InferTypeRules i LCTag where 62 | type InferTypeConstraint e w s r m ki ty pt tm a i LCTag = 63 | (() :: Constraint) 64 | type InferTypeErrorList ki ty pt tm a i LCTag = 65 | '[] 66 | type InferTypeWarningList ki ty pt tm a i LCTag = 67 | '[] 68 | 69 | inferTypeInput _ _ _ = 70 | mempty 71 | -------------------------------------------------------------------------------- /src/Fragment/LC/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.LC.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TmLam.Ast as X 13 | import Fragment.TmApp.Ast as X 14 | -------------------------------------------------------------------------------- /src/Fragment/LC/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.LC.Helpers ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TmVar.Helpers as X 13 | import Fragment.TmLam.Helpers as X 14 | import Fragment.TmApp.Helpers as X 15 | -------------------------------------------------------------------------------- /src/Fragment/LC/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.LC.Rules ( 12 | RLC 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Rules 19 | 20 | import Fragment.TmLam.Ast.Term 21 | import Fragment.TmApp.Ast.Term 22 | 23 | data RLC 24 | 25 | instance AstIn RLC where 26 | type KindList RLC = '[] 27 | type TypeList RLC = '[] 28 | type PatternList RLC = '[] 29 | type TermList RLC = '[TmFLam, TmFApp] 30 | 31 | instance RulesIn RLC where 32 | type InferKindContextSyntax e w s r m ki ty a RLC = 33 | (() :: Constraint) 34 | type InferTypeContextSyntax e w s r m ki ty pt tm a RLC = 35 | (() :: Constraint) 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RLC = 37 | (() :: Constraint) 38 | type ErrorList ki ty pt tm a RLC = '[] 39 | type WarningList ki ty pt tm a RLC = '[] 40 | 41 | inferKindInputSyntax _ = mempty 42 | inferTypeInputSyntax _ = mempty 43 | inferTypeInputOffline _ = mempty 44 | -------------------------------------------------------------------------------- /src/Fragment/LC/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.LC.Rules.Term ( 10 | LCEvalConstraint 11 | , lcEvalRulesStrict 12 | , lcEvalRulesLazy 13 | ) where 14 | 15 | import Bound (instantiate1) 16 | import Control.Lens (review, preview) 17 | import Control.Lens.Wrapped (_Wrapped, _Unwrapped) 18 | 19 | import Rules.Term 20 | import Ast.Term 21 | 22 | import Fragment.TmLam.Ast.Term 23 | import Fragment.TmApp.Ast.Term 24 | 25 | stepTmLamAppLazy :: (TmAstBound ki ty pt tm, AsTmLam ki ty pt tm, AsTmApp ki ty pt tm) => Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 26 | stepTmLamAppLazy tm = do 27 | (tmF, tmX) <- preview _TmApp tm 28 | (_, s) <- preview _TmLam tmF 29 | return . review _Wrapped . instantiate1 (review _Unwrapped tmX) $ s 30 | 31 | stepTmLamAppStrict :: (TmAstBound ki ty pt tm, AsTmLam ki ty pt tm, AsTmApp ki ty pt tm) => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 32 | stepTmLamAppStrict valueFn tm = do 33 | (tmF, tmX) <- preview _TmApp tm 34 | (_, s) <- preview _TmLam tmF 35 | vX <- valueFn tmX 36 | return . review _Wrapped . instantiate1 (review _Unwrapped vX) $ s 37 | 38 | type LCEvalConstraint ki ty pt tm a = 39 | ( AsTmLam ki ty pt tm 40 | , AsTmApp ki ty pt tm 41 | ) 42 | 43 | lcEvalRulesStrict :: LCEvalConstraint ki ty pt tm a 44 | => EvalInput ki ty pt tm a 45 | lcEvalRulesStrict = 46 | EvalInput [] [ StepValue stepTmLamAppStrict ] [] 47 | 48 | lcEvalRulesLazy :: LCEvalConstraint ki ty pt tm a 49 | => EvalInput ki ty pt tm a 50 | lcEvalRulesLazy = 51 | EvalInput [] [ StepBase stepTmLamAppLazy ] [] 52 | -------------------------------------------------------------------------------- /src/Fragment/Let.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Let ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Let.Ast as X 13 | import Fragment.Let.Helpers as X 14 | -------------------------------------------------------------------------------- /src/Fragment/Let/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Let.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Let.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Pair.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Pair.Ast.Type as X 13 | import Fragment.Pair.Ast.Error as X 14 | import Fragment.Pair.Ast.Pattern as X 15 | import Fragment.Pair.Ast.Term as X 16 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Fragment.Pair.Ast.Error ( 17 | ErrExpectedTyPair(..) 18 | , AsExpectedTyPair(..) 19 | , expectTyPair 20 | ) where 21 | 22 | import Control.Monad.Except (MonadError) 23 | import Control.Monad.Error.Lens (throwing) 24 | import Control.Lens (preview) 25 | import Control.Lens.Prism (Prism') 26 | import Control.Lens.TH (makePrisms) 27 | 28 | import Ast.Type 29 | import Ast.Error 30 | 31 | import Fragment.Pair.Ast.Type 32 | 33 | data ErrExpectedTyPair ki ty a = ErrExpectedTyPair (Type ki ty a) 34 | deriving (Eq, Ord, Show) 35 | 36 | makePrisms ''ErrExpectedTyPair 37 | 38 | class AsExpectedTyPair e ki ty a where -- | e -> ty, e -> a where 39 | _ExpectedTyPair :: Prism' e (Type ki ty a) 40 | 41 | instance AsExpectedTyPair (ErrExpectedTyPair ki ty a) ki ty a where 42 | _ExpectedTyPair = _ErrExpectedTyPair 43 | 44 | instance {-# OVERLAPPABLE #-} AsExpectedTyPair (ErrSum xs) ki ty a => AsExpectedTyPair (ErrSum (x ': xs)) ki ty a where 45 | _ExpectedTyPair = _ErrNext . _ExpectedTyPair 46 | 47 | instance {-# OVERLAPPING #-} AsExpectedTyPair (ErrSum (ErrExpectedTyPair ki ty a ': xs)) ki ty a where 48 | _ExpectedTyPair = _ErrNow . _ExpectedTyPair 49 | 50 | expectTyPair :: (MonadError e m, AsExpectedTyPair e ki ty a, AsTyPair ki ty) => Type ki ty a -> m (Type ki ty a, Type ki ty a) 51 | expectTyPair ty = 52 | case preview _TyPair ty of 53 | Just (ty1, ty2) -> return (ty1, ty2) 54 | _ -> throwing _ExpectedTyPair ty 55 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Pair.Helpers ( 9 | tyPair 10 | , ptPair 11 | , tmPair 12 | , tmFst 13 | , tmSnd 14 | ) where 15 | 16 | import Control.Lens (review) 17 | 18 | import Ast.Type 19 | import Ast.Pattern 20 | import Ast.Term 21 | 22 | import Fragment.Pair.Ast.Type 23 | import Fragment.Pair.Ast.Pattern 24 | import Fragment.Pair.Ast.Term 25 | 26 | tyPair :: AsTyPair ki ty => Type ki ty a -> Type ki ty a -> Type ki ty a 27 | tyPair = curry $ review _TyPair 28 | 29 | ptPair :: AsPtPair pt => Pattern pt a -> Pattern pt a -> Pattern pt a 30 | ptPair = curry $ review _PtPair 31 | 32 | tmPair :: AsTmPair ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 33 | tmPair = curry $ review _TmPair 34 | 35 | tmFst :: AsTmPair ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a 36 | tmFst = review _TmFst 37 | 38 | tmSnd :: AsTmPair ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a 39 | tmSnd = review _TmSnd 40 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Pair.Rules ( 12 | RPair 13 | ) where 14 | 15 | import Ast 16 | import Rules 17 | 18 | import Fragment.KiBase.Ast.Kind 19 | 20 | import Fragment.Pair.Ast 21 | import qualified Fragment.Pair.Rules.Kind.Infer.SyntaxDirected as KSD 22 | import qualified Fragment.Pair.Rules.Type.Infer.SyntaxDirected as TSD 23 | import qualified Fragment.Pair.Rules.Type.Infer.Offline as TUO 24 | 25 | data RPair 26 | 27 | instance AstIn RPair where 28 | type KindList RPair = '[KiFBase] 29 | type TypeList RPair = '[TyFPair] 30 | type PatternList RPair = '[PtFPair] 31 | type TermList RPair = '[TmFPair] 32 | 33 | instance RulesIn RPair where 34 | type InferKindContextSyntax e w s r m ki ty a RPair = KSD.PairInferKindContext e w s r m ki ty a 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RPair = TSD.PairInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RPair = TUO.PairInferTypeContext e w s r m ki ty pt tm a 37 | type ErrorList ki ty pt tm a RPair = '[ErrExpectedTyPair ki ty a] 38 | type WarningList ki ty pt tm a RPair = '[] 39 | 40 | inferKindInputSyntax _ = KSD.pairInferKindRules 41 | inferTypeInputSyntax _ = TSD.pairInferTypeRules 42 | inferTypeInputOffline _ = TUO.pairInferTypeRules 43 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.Pair.Rules.Kind.Infer.Common ( 13 | PairInferKindConstraint 14 | , pairInferKindInput 15 | ) where 16 | 17 | import Data.Proxy (Proxy(..)) 18 | 19 | import Control.Lens (review, preview) 20 | 21 | import Ast.Kind 22 | import Ast.Type 23 | import Rules.Kind.Infer.Common 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Pair.Ast.Type 27 | 28 | type PairInferKindConstraint e w s r m ki ty a i = 29 | ( BasicInferKindConstraint e w s r m ki ty a i 30 | , AsKiBase ki 31 | , AsTyPair ki ty 32 | ) 33 | 34 | pairInferKindInput :: PairInferKindConstraint e w s r m ki ty a i 35 | => Proxy (MonadProxy e w s r m) 36 | -> Proxy i 37 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 38 | pairInferKindInput m i = 39 | InferKindInput 40 | [] 41 | [ InferKindRecurse $ inferTyPair m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 42 | 43 | inferTyPair :: PairInferKindConstraint e w s r m ki ty a i 44 | => Proxy (MonadProxy e w s r m) 45 | -> Proxy ki 46 | -> Proxy ty 47 | -> Proxy a 48 | -> Proxy i 49 | -> (Type ki ty a -> InferKindMonad m ki a i (Kind ki a)) 50 | -> Type ki ty a 51 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 52 | inferTyPair pm pki pty pa pi inferFn ty = do 53 | (ty1, ty2) <- preview _TyPair ty 54 | return $ do 55 | let kib = review _KiBase () 56 | mkCheckKind pm pki pty pa pi inferFn ty1 kib 57 | mkCheckKind pm pki pty pa pi inferFn ty2 kib 58 | return kib 59 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Pair.Rules.Kind.Infer.SyntaxDirected ( 10 | PairInferKindContext 11 | , pairInferKindRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | import Control.Monad.Except (MonadError) 16 | import Data.Functor.Classes (Eq1) 17 | 18 | import Ast.Kind 19 | import Ast.Type 20 | import Ast.Error.Common 21 | import Rules.Kind.Infer.SyntaxDirected 22 | 23 | import Fragment.KiBase.Ast.Kind 24 | import Fragment.Pair.Ast.Type 25 | 26 | inferTyPair :: (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyPair ki ty) 27 | => (Type ki ty a -> m (Kind ki)) 28 | -> Type ki ty a 29 | -> Maybe (m (Kind ki)) 30 | inferTyPair inferFn ty = do 31 | (ty1, ty2) <- preview _TyPair ty 32 | return $ do 33 | let ki = review _KiBase() 34 | mkCheckKind inferFn ty1 ki 35 | mkCheckKind inferFn ty2 ki 36 | return . review _KiBase $ () 37 | 38 | type PairInferKindContext e w s r m ki ty a = (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyPair ki ty) 39 | 40 | pairInferKindRules :: PairInferKindContext e w s r m ki ty a 41 | => InferKindInput e w s r m ki ty a 42 | pairInferKindRules = 43 | InferKindInput 44 | [InferKindRecurse inferTyPair] 45 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Pair.Rules.Type ( 10 | PairNormalizeConstraint 11 | , pairNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.Pair.Ast.Type 20 | 21 | type PairNormalizeConstraint ki ty a = AsTyPair ki ty 22 | 23 | normalizePair :: PairNormalizeConstraint ki ty a 24 | => (Type ki ty a -> Type ki ty a) 25 | -> Type ki ty a 26 | -> Maybe (Type ki ty a) 27 | normalizePair normalizeFn ty = do 28 | (p1, p2) <- preview _TyPair ty 29 | return $ review _TyPair (normalizeFn p1, normalizeFn p2) 30 | 31 | pairNormalizeRules :: PairNormalizeConstraint ki ty a 32 | => NormalizeInput ki ty a 33 | pairNormalizeRules = 34 | NormalizeInput [ NormalizeTypeRecurse normalizePair ] 35 | -------------------------------------------------------------------------------- /src/Fragment/Pair/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Pair.Rules.Type.Infer.SyntaxDirected ( 10 | PairInferTypeContext 11 | , pairInferTypeRules 12 | ) where 13 | 14 | import Control.Monad.Except (MonadError) 15 | import Control.Lens (review) 16 | 17 | import Rules.Type.Infer.SyntaxDirected 18 | import Ast.Type 19 | 20 | import Fragment.Pair.Ast.Type 21 | import Fragment.Pair.Ast.Error 22 | import Fragment.Pair.Ast.Pattern 23 | import Fragment.Pair.Ast.Term 24 | 25 | import Fragment.Pair.Rules.Type.Infer.Common 26 | 27 | createPair :: (Monad m, AsTyPair ki ty) => Type ki ty a -> Type ki ty a -> m (Type ki ty a) 28 | createPair ty1 ty2 = 29 | return . review _TyPair $ (ty1, ty2) 30 | 31 | expectPair :: (MonadError e m, AsExpectedTyPair e ki ty a, AsTyPair ki ty) => Type ki ty a -> m (Type ki ty a, Type ki ty a) 32 | expectPair = 33 | expectTyPair 34 | 35 | type PairInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsTyPair ki ty, AsExpectedTyPair e ki ty a, AsPtPair pt, AsTmPair ki ty pt tm) 36 | 37 | pairInferTypeRules :: PairInferTypeContext e w s r m ki ty pt tm a 38 | => InferTypeInput e w s r m m ki ty pt tm a 39 | pairInferTypeRules = 40 | let 41 | ph = PairHelper createPair expectPair 42 | in 43 | inferTypeInput ph 44 | -------------------------------------------------------------------------------- /src/Fragment/PtVar.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.PtVar ( 13 | module X 14 | , PtVarTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | 24 | import Fragment.PtVar.Helpers as X 25 | 26 | import Fragment.PtVar.Rules.Type.Infer.Common 27 | import Fragment.PtVar.Rules.Term 28 | 29 | data PtVarTag 30 | 31 | instance AstIn PtVarTag where 32 | type KindList PtVarTag = '[] 33 | type TypeList PtVarTag = '[] 34 | type TypeSchemeList PtVarTag = '[] 35 | type PatternList PtVarTag = '[] 36 | type TermList PtVarTag = '[] 37 | 38 | instance EvalRules e PtVarTag where 39 | type EvalConstraint ki ty pt tm a e PtVarTag = 40 | PtVarEvalConstraint ki ty pt tm a 41 | 42 | evalInput _ _ = 43 | ptVarEvalRules 44 | 45 | instance NormalizeRules PtVarTag where 46 | type NormalizeConstraint ki ty a PtVarTag = 47 | (() :: Constraint) 48 | 49 | normalizeInput _ = 50 | mempty 51 | 52 | instance MkInferType i => InferTypeRules i PtVarTag where 53 | type InferTypeConstraint e w s r m ki ty pt tm a i PtVarTag = 54 | PtVarInferTypeConstraint e w s r m ki ty pt tm a i 55 | type InferTypeErrorList ki ty pt tm a i PtVarTag = 56 | '[] 57 | type InferTypeWarningList ki ty pt tm a i PtVarTag = 58 | '[] 59 | 60 | inferTypeInput m i _ = 61 | ptVarInferTypeInput m i 62 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.PtVar.Helpers ( 9 | ptVar 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Pattern 15 | 16 | ptVar :: a -> Pattern pt a 17 | ptVar = review _PtVar 18 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.PtVar.Rules ( 12 | RPtVar 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Rules 19 | 20 | import qualified Fragment.PtVar.Rules.Type.Infer.SyntaxDirected as SD 21 | import qualified Fragment.PtVar.Rules.Type.Infer.Offline as UO 22 | 23 | data RPtVar 24 | 25 | instance AstIn RPtVar where 26 | type KindList RPtVar = '[] 27 | type TypeList RPtVar = '[] 28 | type PatternList RPtVar = '[] 29 | type TermList RPtVar = '[] 30 | 31 | instance RulesIn RPtVar where 32 | type InferKindContextSyntax e w s r m ki ty a RPtVar = (() :: Constraint) 33 | type InferTypeContextSyntax e w s r m ki ty pt tm a RPtVar = SD.PtVarInferTypeContext e w s r m ki ty pt tm a 34 | type InferTypeContextOffline e w s r m ki ty pt tm a RPtVar = UO.PtVarInferTypeContext e w s r m ki ty pt tm a 35 | type ErrorList ki ty pt tm a RPtVar = '[] 36 | type WarningList ki ty pt tm a RPtVar = '[] 37 | 38 | inferKindInputSyntax _ = mempty 39 | inferTypeInputSyntax _ = SD.ptVarInferTypeRules 40 | inferTypeInputOffline _ = UO.ptVarInferTypeRules 41 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.PtVar.Rules.Term ( 10 | PtVarEvalConstraint 11 | , ptVarEvalRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Term 17 | 18 | import Ast.Pattern 19 | import Ast.Term 20 | 21 | matchVar :: Pattern pt a -> Term ki ty pt tm a -> Maybe [Term ki ty pt tm a] 22 | matchVar p tm = do 23 | _ <- preview _PtVar p 24 | return [tm] 25 | 26 | type PtVarEvalConstraint ki ty pt tm a = BasicEvalConstraint ki ty pt tm a 27 | 28 | ptVarEvalRules :: PtVarEvalConstraint ki ty pt tm a 29 | => EvalInput ki ty pt tm a 30 | ptVarEvalRules = 31 | EvalInput 32 | [] 33 | [] 34 | [ MatchBase matchVar ] 35 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.PtVar.Rules.Type.Infer.Common ( 11 | PtVarInferTypeConstraint 12 | , ptVarInferTypeInput 13 | ) where 14 | 15 | import Data.Proxy (Proxy) 16 | 17 | import Control.Lens (preview) 18 | 19 | import Ast.Pattern 20 | import Ast.Type 21 | 22 | import Rules.Type.Infer.Common 23 | 24 | type PtVarInferTypeConstraint e w s r m ki ty pt tm a i = 25 | ( BasicInferTypeConstraint e w s r m ki ty pt tm a i 26 | ) 27 | 28 | checkVar :: PtVarInferTypeConstraint e w s r m ki ty pt tm a i 29 | => Proxy (MonadProxy e w s r m ) 30 | -> Proxy i 31 | -> Pattern pt a 32 | -> Type ki ty a 33 | -> Maybe (InferTypeMonad m ki ty a i [Type ki ty a]) 34 | checkVar _ _ p ty = do 35 | _ <- preview _PtVar p 36 | return $ 37 | return [ty] 38 | 39 | ptVarInferTypeInput :: PtVarInferTypeConstraint e w s r m ki ty pt tm a i 40 | => Proxy (MonadProxy e w s r m) 41 | -> Proxy i 42 | -> InferTypeInput e w s r m (InferTypeMonad m ki ty a i) ki ty pt tm a 43 | ptVarInferTypeInput m i = 44 | InferTypeInput [] [] [ PCheckBase $ checkVar m i ] 45 | 46 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.PtVar.Rules.Type.Infer.Offline ( 11 | PtVarInferTypeContext 12 | , ptVarInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.Offline 16 | import Fragment.PtVar.Rules.Type.Infer.Common 17 | 18 | type PtVarInferTypeContext e w s r m ki ty pt tm a = InferTypeContext e w s r m ki ty pt tm a 19 | 20 | ptVarInferTypeRules :: PtVarInferTypeContext e w s r m ki ty pt tm a 21 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 22 | ptVarInferTypeRules = 23 | inferTypeRules 24 | -------------------------------------------------------------------------------- /src/Fragment/PtVar/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.PtVar.Rules.Type.Infer.SyntaxDirected ( 10 | PtVarInferTypeContext 11 | , ptVarInferTypeRules 12 | ) where 13 | 14 | import Rules.Type.Infer.SyntaxDirected 15 | import Fragment.PtVar.Rules.Type.Infer.Common 16 | 17 | type PtVarInferTypeContext e w s r m ki ty pt tm a = InferTypeContext e w s r m ki ty pt tm a 18 | 19 | ptVarInferTypeRules :: PtVarInferTypeContext e w s r m ki ty pt tm a 20 | => InferTypeInput e w s r m m ki ty pt tm a 21 | ptVarInferTypeRules = 22 | inferTypeRules 23 | -------------------------------------------------------------------------------- /src/Fragment/PtWild.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.PtWild ( 13 | module X 14 | , PtWildTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Ast.Pattern 21 | import Rules.Type 22 | import Rules.Type.Infer.Common 23 | import Rules.Term 24 | 25 | import Fragment.PtWild.Helpers as X 26 | 27 | import Fragment.PtWild.Rules.Type.Infer.Common 28 | import Fragment.PtWild.Rules.Term 29 | 30 | data PtWildTag 31 | 32 | instance AstIn PtWildTag where 33 | type KindList PtWildTag = '[] 34 | type TypeList PtWildTag = '[] 35 | type TypeSchemeList PtWildTag = '[] 36 | type PatternList PtWildTag = '[PtFWild] 37 | type TermList PtWildTag = '[] 38 | 39 | instance EvalRules e PtWildTag where 40 | type EvalConstraint ki ty pt tm a e PtWildTag = 41 | PtWildEvalConstraint ki ty pt tm a 42 | 43 | evalInput _ _ = 44 | ptWildEvalRules 45 | 46 | instance NormalizeRules PtWildTag where 47 | type NormalizeConstraint ki ty a PtWildTag = 48 | (() :: Constraint) 49 | 50 | normalizeInput _ = 51 | mempty 52 | 53 | instance MkInferType i => InferTypeRules i PtWildTag where 54 | type InferTypeConstraint e w s r m ki ty pt tm a i PtWildTag = 55 | PtWildInferTypeConstraint e w s r m ki ty pt tm a i 56 | type InferTypeErrorList ki ty pt tm a i PtWildTag = 57 | '[] 58 | type InferTypeWarningList ki ty pt tm a i PtWildTag = 59 | '[] 60 | 61 | inferTypeInput m i _ = 62 | ptWildInferTypeInput m i 63 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.PtWild.Helpers ( 9 | ptWild 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Pattern 15 | 16 | ptWild :: AsPtWild pt => Pattern pt a 17 | ptWild = review _PtWild () 18 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.PtWild.Rules ( 12 | RPtWild 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Pattern 19 | import Rules 20 | 21 | import qualified Fragment.PtWild.Rules.Type.Infer.SyntaxDirected as SD 22 | import qualified Fragment.PtWild.Rules.Type.Infer.Offline as UO 23 | 24 | data RPtWild 25 | 26 | instance AstIn RPtWild where 27 | type KindList RPtWild = '[] 28 | type TypeList RPtWild = '[] 29 | type PatternList RPtWild = '[PtFWild] 30 | type TermList RPtWild = '[] 31 | 32 | instance RulesIn RPtWild where 33 | type InferKindContextSyntax e w s r m ki ty a RPtWild = (() :: Constraint) 34 | type InferTypeContextSyntax e w s r m ki ty pt tm a RPtWild = SD.PtWildInferTypeContext e w s r m ki ty pt tm a 35 | type InferTypeContextOffline e w s r m ki ty pt tm a RPtWild = UO.PtWildInferTypeContext e w s r m ki ty pt tm a 36 | type ErrorList ki ty pt tm a RPtWild = '[] 37 | type WarningList ki ty pt tm a RPtWild = '[] 38 | 39 | inferKindInputSyntax _ = mempty 40 | inferTypeInputSyntax _ = SD.ptWildInferTypeRules 41 | inferTypeInputOffline _ = UO.ptWildInferTypeRules 42 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.PtWild.Rules.Term ( 10 | PtWildEvalConstraint 11 | , ptWildEvalRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Term 17 | 18 | import Ast.Pattern 19 | import Ast.Term 20 | 21 | matchWild :: AsPtWild pt => Pattern pt a -> Term ki ty pt tm a -> Maybe [Term ki ty pt tm a] 22 | matchWild p _ = do 23 | _ <- preview _PtWild p 24 | return [] 25 | 26 | type PtWildEvalConstraint ki ty pt tm a = 27 | ( BasicEvalConstraint ki ty pt tm a 28 | , AsPtWild pt 29 | ) 30 | 31 | ptWildEvalRules :: PtWildEvalConstraint ki ty pt tm a 32 | => EvalInput ki ty pt tm a 33 | ptWildEvalRules = 34 | EvalInput 35 | [] 36 | [] 37 | [ MatchBase matchWild ] 38 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.PtWild.Rules.Type.Infer.Common ( 11 | PtWildInferTypeConstraint 12 | , ptWildInferTypeInput 13 | ) where 14 | 15 | import Data.Proxy (Proxy) 16 | 17 | import Control.Lens (preview) 18 | 19 | import Ast.Pattern 20 | import Ast.Type 21 | 22 | import Rules.Type.Infer.Common 23 | 24 | type PtWildInferTypeConstraint e w s r m ki ty pt tm a i = 25 | ( BasicInferTypeConstraint e w s r m ki ty pt tm a i 26 | , AsPtWild pt 27 | ) 28 | 29 | checkWild :: PtWildInferTypeConstraint e w s r m ki ty pt tm a i 30 | => Proxy (MonadProxy e w s r m ) 31 | -> Proxy i 32 | -> Pattern pt a 33 | -> Type ki ty a 34 | -> Maybe (InferTypeMonad m ki ty a i [Type ki ty a]) 35 | checkWild _ _ p _ = do 36 | _ <- preview _PtWild p 37 | return $ 38 | return [] 39 | 40 | ptWildInferTypeInput :: PtWildInferTypeConstraint e w s r m ki ty pt tm a i 41 | => Proxy (MonadProxy e w s r m) 42 | -> Proxy i 43 | -> InferTypeInput e w s r m (InferTypeMonad m ki ty a i) ki ty pt tm a 44 | ptWildInferTypeInput m i = 45 | InferTypeInput [] [] [ PCheckBase $ checkWild m i ] 46 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.PtWild.Rules.Type.Infer.Offline ( 11 | PtWildInferTypeContext 12 | , ptWildInferTypeRules 13 | ) where 14 | 15 | import Ast.Pattern 16 | import Rules.Type.Infer.Offline 17 | 18 | import Fragment.PtWild.Rules.Type.Infer.Common 19 | 20 | type PtWildInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsPtWild pt) 21 | 22 | ptWildInferTypeRules :: PtWildInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 24 | ptWildInferTypeRules = 25 | inferTypeInput 26 | -------------------------------------------------------------------------------- /src/Fragment/PtWild/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.PtWild.Rules.Type.Infer.SyntaxDirected ( 10 | PtWildInferTypeContext 11 | , ptWildInferTypeRules 12 | ) where 13 | 14 | import Ast.Pattern 15 | import Rules.Type.Infer.SyntaxDirected 16 | 17 | import Fragment.PtWild.Rules.Type.Infer.Common 18 | 19 | type PtWildInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, AsPtWild pt) 20 | 21 | ptWildInferTypeRules :: PtWildInferTypeContext e w s r m ki ty pt tm a 22 | => InferTypeInput e w s r m m ki ty pt tm a 23 | ptWildInferTypeRules = 24 | inferTypeInput 25 | -------------------------------------------------------------------------------- /src/Fragment/Record/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Record.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Record.Ast.Type as X 13 | import Fragment.Record.Ast.Error as X 14 | import Fragment.Record.Ast.Pattern as X 15 | import Fragment.Record.Ast.Term as X 16 | -------------------------------------------------------------------------------- /src/Fragment/Record/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Record.Helpers ( 9 | tyRecord 10 | , ptRecord 11 | , tmRecord 12 | , tmRecordIx 13 | ) where 14 | 15 | import Control.Lens (review) 16 | 17 | import qualified Data.Text as T 18 | 19 | import Ast.Type 20 | import Ast.Pattern 21 | import Ast.Term 22 | 23 | import Fragment.Record.Ast.Type 24 | import Fragment.Record.Ast.Pattern 25 | import Fragment.Record.Ast.Term 26 | 27 | tyRecord :: AsTyRecord ki ty => [(T.Text, Type ki ty a)] -> Type ki ty a 28 | tyRecord = review _TyRecord 29 | 30 | ptRecord :: AsPtRecord pt => [(T.Text, Pattern pt a)] -> Pattern pt a 31 | ptRecord = review _PtRecord 32 | 33 | tmRecord :: AsTmRecord ki ty pt tm => [(T.Text, Term ki ty pt tm a)] -> Term ki ty pt tm a 34 | tmRecord = review _TmRecord 35 | 36 | tmRecordIx :: AsTmRecord ki ty pt tm => Term ki ty pt tm a -> T.Text -> Term ki ty pt tm a 37 | tmRecordIx = curry $ review _TmRecordIx 38 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Record.Rules ( 12 | RRecord 13 | ) where 14 | 15 | import Ast 16 | import Rules 17 | 18 | import Fragment.KiBase.Ast.Kind 19 | 20 | import Fragment.Record.Ast 21 | import qualified Fragment.Record.Rules.Kind.Infer.SyntaxDirected as KSD 22 | import qualified Fragment.Record.Rules.Type.Infer.SyntaxDirected as TSD 23 | import qualified Fragment.Record.Rules.Type.Infer.Offline as TUO 24 | 25 | data RRecord 26 | 27 | instance AstIn RRecord where 28 | type KindList RRecord = '[KiFBase] 29 | type TypeList RRecord = '[TyFRecord] 30 | type PatternList RRecord = '[PtFRecord] 31 | type TermList RRecord = '[TmFRecord] 32 | 33 | instance RulesIn RRecord where 34 | type InferKindContextSyntax e w s r m ki ty a RRecord = KSD.RecordInferKindContext e w s r m ki ty a 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RRecord = TSD.RecordInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RRecord = TUO.RecordInferTypeContext e w s r m ki ty pt tm a 37 | type ErrorList ki ty pt tm a RRecord = '[ErrExpectedTyRecord ki ty a, ErrRecordNotFound] 38 | type WarningList ki ty pt tm a RRecord = '[] 39 | 40 | inferKindInputSyntax _ = KSD.recordInferKindRules 41 | inferTypeInputSyntax _ = TSD.recordInferTypeRules 42 | inferTypeInputOffline _ = TUO.recordInferTypeRules 43 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.Record.Rules.Kind.Infer.Common ( 13 | RecordInferKindConstraint 14 | , recordInferKindInput 15 | ) where 16 | 17 | import Data.Foldable (traverse_) 18 | import Data.Proxy (Proxy(..)) 19 | 20 | import Control.Lens (review, preview) 21 | 22 | import Ast.Kind 23 | import Ast.Type 24 | import Rules.Kind.Infer.Common 25 | 26 | import Fragment.KiBase.Ast.Kind 27 | import Fragment.Record.Ast.Type 28 | 29 | type RecordInferKindConstraint e w s r m ki ty a i = 30 | ( BasicInferKindConstraint e w s r m ki ty a i 31 | , AsKiBase ki 32 | , AsTyRecord ki ty 33 | ) 34 | 35 | recordInferKindInput :: RecordInferKindConstraint e w s r m ki ty a i 36 | => Proxy (MonadProxy e w s r m) 37 | -> Proxy i 38 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 39 | recordInferKindInput m i = 40 | InferKindInput 41 | [] 42 | [ InferKindRecurse $ inferTyRecord m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 43 | 44 | inferTyRecord :: RecordInferKindConstraint e w s r m ki ty a i 45 | => Proxy (MonadProxy e w s r m) 46 | -> Proxy ki 47 | -> Proxy ty 48 | -> Proxy a 49 | -> Proxy i 50 | -> (Type ki ty a -> InferKindMonad m ki a i (Kind ki a)) 51 | -> Type ki ty a 52 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 53 | inferTyRecord pm pki pty pa pi inferFn ty = do 54 | tys <- preview _TyRecord ty 55 | return $ do 56 | let kib = review _KiBase () 57 | traverse_ (traverse (\tyT -> mkCheckKind pm pki pty pa pi inferFn tyT kib)) tys 58 | return kib 59 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Record.Rules.Kind.Infer.SyntaxDirected ( 10 | RecordInferKindContext 11 | , recordInferKindRules 12 | ) where 13 | 14 | import Data.Foldable (traverse_) 15 | 16 | import Control.Lens (review, preview) 17 | import Control.Monad.Except (MonadError) 18 | import Data.Functor.Classes (Eq1) 19 | 20 | import Ast.Kind 21 | import Ast.Type 22 | import Ast.Error.Common 23 | import Rules.Kind.Infer.SyntaxDirected 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Record.Ast.Type 27 | 28 | inferTyRecord :: (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyRecord ki ty) 29 | => (Type ki ty a -> m (Kind ki)) 30 | -> Type ki ty a 31 | -> Maybe (m (Kind ki)) 32 | inferTyRecord inferFn ty = do 33 | tys <- preview _TyRecord ty 34 | return $ do 35 | let ki = review _KiBase() 36 | traverse_ (\(_, tyR) -> mkCheckKind inferFn tyR ki) tys 37 | return . review _KiBase $ () 38 | 39 | type RecordInferKindContext e w s r m ki ty a = (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyRecord ki ty) 40 | 41 | recordInferKindRules :: RecordInferKindContext e w s r m ki ty a 42 | => InferKindInput e w s r m ki ty a 43 | recordInferKindRules = 44 | InferKindInput 45 | [InferKindRecurse inferTyRecord] 46 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Record.Rules.Type ( 10 | RecordNormalizeConstraint 11 | , recordNormalizeRules 12 | ) where 13 | 14 | import Data.List (sortOn) 15 | 16 | import Control.Lens (review, preview) 17 | 18 | import Rules.Type 19 | import Ast.Type 20 | 21 | import Fragment.Record.Ast.Type 22 | 23 | type RecordNormalizeConstraint ki ty a = AsTyRecord ki ty 24 | 25 | normalizeRecord :: RecordNormalizeConstraint ki ty a 26 | => (Type ki ty a -> Type ki ty a) 27 | -> Type ki ty a 28 | -> Maybe (Type ki ty a) 29 | normalizeRecord normalizeFn ty = do 30 | tys <- preview _TyRecord ty 31 | return $ review _TyRecord (sortOn fst . fmap (fmap normalizeFn) $ tys) 32 | 33 | recordNormalizeRules :: RecordNormalizeConstraint ki ty a 34 | => NormalizeInput ki ty a 35 | recordNormalizeRules = 36 | NormalizeInput [ NormalizeTypeRecurse normalizeRecord ] 37 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Record.Rules.Type.Infer.Offline ( 11 | RecordInferTypeContext 12 | , recordInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.Offline 16 | 17 | import qualified Fragment.Record.Rules.Type.Infer.Common as R 18 | 19 | type RecordInferTypeContext e w s r m ki ty pt tm a = 20 | R.RecordInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 21 | 22 | recordInferTypeRules :: RecordInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 24 | recordInferTypeRules = 25 | R.inferTypeInput 26 | -------------------------------------------------------------------------------- /src/Fragment/Record/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Record.Rules.Type.Infer.SyntaxDirected ( 11 | RecordInferTypeContext 12 | , recordInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.SyntaxDirected 16 | 17 | import qualified Fragment.Record.Rules.Type.Infer.Common as R 18 | 19 | type RecordInferTypeContext e w s r m ki ty pt tm a = 20 | R.RecordInferTypeContext e w s r m m ki ty pt tm a 21 | 22 | recordInferTypeRules :: RecordInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m m ki ty pt tm a 24 | recordInferTypeRules = 25 | R.inferTypeInput 26 | -------------------------------------------------------------------------------- /src/Fragment/STLC.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.STLC ( 9 | module X 10 | ) where 11 | 12 | import Fragment.STLC.Ast as X 13 | import Fragment.STLC.Rules as X 14 | import Fragment.STLC.Helpers as X 15 | -------------------------------------------------------------------------------- /src/Fragment/SystemF.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.SystemF ( 13 | module X 14 | , SystemFTag 15 | ) where 16 | 17 | import Ast 18 | import Rules.Type.Infer.Common 19 | import Rules.Term 20 | 21 | import Fragment.SystemF.Ast as X 22 | import Fragment.SystemF.Helpers as X 23 | 24 | import Fragment.KiBase.Ast.Kind 25 | import Fragment.KiArr.Ast.Kind 26 | import Fragment.TyArr.Ast.Type 27 | import Fragment.TyAll.Ast.Type 28 | import Fragment.TyAll.Ast.Error 29 | import Fragment.TmLam.Ast.Term 30 | import Fragment.TmApp.Ast.Term 31 | 32 | import Fragment.SystemF.Rules.Type.Infer.Common 33 | import Fragment.SystemF.Rules.Term 34 | 35 | data SystemFTag 36 | 37 | instance AstIn SystemFTag where 38 | type KindList SystemFTag = '[KiFBase, KiFArr] 39 | type TypeList SystemFTag = '[TyFArr, TyFAll] 40 | type TypeSchemeList SystemFTag = '[] 41 | type PatternList SystemFTag = '[] 42 | type TermList SystemFTag = '[TmFLam, TmFApp, TmFSystemF] 43 | 44 | instance EvalRules e SystemFTag where 45 | type EvalConstraint ki ty pt tm a e SystemFTag = 46 | SystemFEvalConstraint ki ty pt tm a 47 | 48 | evalInput _ _ = 49 | systemFEvalRules 50 | 51 | instance MkInferType i => InferTypeRules i SystemFTag where 52 | type InferTypeConstraint e w s r m ki ty pt tm a i SystemFTag = 53 | SystemFInferTypeConstraint e w s r m ki ty pt tm a i 54 | type InferTypeErrorList ki ty pt tm a i SystemFTag = 55 | '[ ErrExpectedTyAll ki ty a ] 56 | type InferTypeWarningList ki ty pt tm a i SystemFTag = 57 | '[] 58 | 59 | inferTypeInput m i _ = 60 | systemFInferTypeInput m i 61 | -------------------------------------------------------------------------------- /src/Fragment/SystemF/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.SystemF.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.SystemF.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/SystemF/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.SystemF.Helpers ( 9 | tmLamTy 10 | , tmLamTyAnn 11 | , tmLamTyNoAnn 12 | , tmAppTy 13 | ) where 14 | 15 | import Bound (abstract1) 16 | import Control.Lens (review) 17 | import Control.Lens.Wrapped (_Unwrapped) 18 | 19 | import Ast.Kind 20 | import Ast.Type 21 | import Ast.Term 22 | 23 | import Fragment.SystemF.Ast.Term 24 | 25 | tmLamTy :: (Eq a, AsTmSystemF ki ty pt tm) => a -> Maybe (Kind ki a) -> Term ki ty pt tm a -> Term ki ty pt tm a 26 | tmLamTy v ki tm = review _TmLamTy (ki, abstract1 (review _TmAstTyVar v) . review _Unwrapped $ tm) 27 | 28 | tmLamTyAnn :: (Eq a, AsTmSystemF ki ty pt tm) => a -> Kind ki a -> Term ki ty pt tm a -> Term ki ty pt tm a 29 | tmLamTyAnn v ki tm = review _TmLamTyAnn (ki, abstract1 (review _TmAstTyVar v) . review _Unwrapped $ tm) 30 | 31 | tmLamTyNoAnn :: (Eq a, AsTmSystemF ki ty pt tm) => a -> Term ki ty pt tm a -> Term ki ty pt tm a 32 | tmLamTyNoAnn v tm = review _TmLamTyNoAnn (abstract1 (review _TmAstTyVar v) . review _Unwrapped $ tm) 33 | 34 | tmAppTy :: AsTmSystemF ki ty pt tm => Term ki ty pt tm a -> Type ki ty a -> Term ki ty pt tm a 35 | tmAppTy = curry $ review _TmAppTy 36 | -------------------------------------------------------------------------------- /src/Fragment/SystemF/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.SystemF.Rules ( 12 | RSystemF 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Error.Common 19 | import Rules 20 | 21 | import Fragment.SystemF.Ast 22 | import Fragment.SystemF.Rules.Kind.Infer.SyntaxDirected 23 | import Fragment.SystemF.Rules.Type.Infer.SyntaxDirected 24 | 25 | data RSystemF 26 | 27 | instance AstIn RSystemF where 28 | type KindList RSystemF = '[] 29 | type TypeList RSystemF = '[TyFSystemF] 30 | type PatternList RSystemF = '[] 31 | type TermList RSystemF = '[TmFSystemF] 32 | 33 | instance RulesIn RSystemF where 34 | type InferKindContextSyntax e w s r m ki ty a RSystemF = SystemFInferKindContext e w s r m ki ty a 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RSystemF = SystemFInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RSystemF = (() :: Constraint) 37 | type ErrorList ki ty pt tm a RSystemF = '[ErrUnexpectedKind ki, ErrExpectedTyArr ki ty a, ErrExpectedTyAll ki ty a] 38 | type WarningList ki ty pt tm a RSystemF = '[] 39 | 40 | inferKindInputSyntax _ = systemFInferKindRules 41 | inferTypeInputSyntax _ = systemFInferTypeRules 42 | inferTypeInputOffline _ = mempty 43 | -------------------------------------------------------------------------------- /src/Fragment/SystemF/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.SystemF.Rules.Term ( 10 | SystemFEvalConstraint 11 | , systemFEvalRules 12 | ) where 13 | 14 | import Bound (Bound, instantiate1) 15 | import Control.Lens (review, preview) 16 | import Control.Lens.Wrapped (_Wrapped) 17 | 18 | import Rules.Term 19 | import Ast.Term 20 | 21 | import Fragment.SystemF.Ast.Term 22 | 23 | valTmLamTy :: AsTmSystemF ki ty pt tm => Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 24 | valTmLamTy tm = do 25 | _ <- preview _TmLamTy tm 26 | return tm 27 | 28 | stepTmAppTy1 :: AsTmSystemF ki ty pt tm => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 29 | stepTmAppTy1 evalFn tm = do 30 | (f, x) <- preview _TmAppTy tm 31 | f' <- evalFn f 32 | return $ review _TmAppTy (f', x) 33 | 34 | stepTmLamTyAppTy :: (Bound ki, Bound (ty ki), Bound pt, Bound (tm ki ty pt)) => AsTmSystemF ki ty pt tm => Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 35 | stepTmLamTyAppTy tm = do 36 | (tmF, tyX) <- preview _TmAppTy tm 37 | (_, s) <- preview _TmLamTy tmF 38 | return . review _Wrapped . instantiate1 (review _TmType tyX) $ s 39 | 40 | type SystemFEvalConstraint ki ty pt tm a = 41 | AsTmSystemF ki ty pt tm 42 | 43 | systemFEvalRules :: SystemFEvalConstraint ki ty pt tm a 44 | => EvalInput ki ty pt tm a 45 | systemFEvalRules = 46 | EvalInput 47 | [ ValueBase valTmLamTy ] 48 | [ StepRecurse stepTmAppTy1 49 | , StepBase stepTmLamTyAppTy 50 | ] 51 | [] 52 | -------------------------------------------------------------------------------- /src/Fragment/SystemF/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | module Fragment.SystemF.Rules.Type ( 11 | SystemFNormalizeConstraint 12 | , systemFNormalizeRules 13 | ) where 14 | 15 | import Bound (Bound) 16 | import Control.Lens (review, preview) 17 | 18 | import Ast.Type 19 | import Data.Bitransversable 20 | import Rules.Type 21 | 22 | import Fragment.SystemF.Ast.Type 23 | 24 | type SystemFNormalizeConstraint ki ty a = 25 | ( AsTySystemF ki ty 26 | , Bound ki 27 | , Bitransversable ki 28 | ) 29 | 30 | normalizeArr :: SystemFNormalizeConstraint ki ty a 31 | => (Type ki ty a -> Type ki ty a) 32 | -> Type ki ty a 33 | -> Maybe (Type ki ty a) 34 | normalizeArr normalizeFn ty = do 35 | (ty1, ty2) <- preview _TyArr ty 36 | return $ review _TyArr (normalizeFn ty1, normalizeFn ty2) 37 | 38 | normalizeAll :: SystemFNormalizeConstraint ki ty a 39 | => (forall b. Type ki ty b -> Type ki ty b) 40 | -> Type ki ty a 41 | -> Maybe (Type ki ty a) 42 | normalizeAll normalizeFn ty = do 43 | s <- preview _TyAll ty 44 | return $ review _TyAll (scopeAppTy normalizeFn s) 45 | 46 | systemFNormalizeRules :: SystemFNormalizeConstraint ki ty a 47 | => NormalizeInput ki ty a 48 | systemFNormalizeRules = 49 | NormalizeInput 50 | [ NormalizeTypeRecurse normalizeArr 51 | , NormalizeTypeRecurse normalizeAll 52 | ] 53 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.SystemFw ( 13 | module X 14 | , SystemFwTag 15 | ) where 16 | 17 | import Ast 18 | import Rules.Type 19 | import Rules.Kind.Infer.Common 20 | 21 | import Fragment.SystemFw.Ast as X 22 | import Fragment.SystemFw.Helpers as X 23 | 24 | import Fragment.KiBase.Ast.Kind 25 | import Fragment.KiArr.Ast.Kind 26 | import Fragment.TyArr.Ast.Type 27 | import Fragment.TyAll.Ast.Type 28 | import Fragment.TmLam.Ast.Term 29 | import Fragment.TmApp.Ast.Term 30 | import Fragment.SystemF.Ast.Term 31 | 32 | import Fragment.SystemFw.Rules.Type 33 | import Fragment.SystemFw.Rules.Kind.Infer.Common 34 | 35 | data SystemFwTag 36 | 37 | instance AstIn SystemFwTag where 38 | type KindList SystemFwTag = '[KiFBase, KiFArr] 39 | type TypeList SystemFwTag = '[TyFArr, TyFAll, TyFSystemFw] 40 | type TypeSchemeList SystemFwTag = '[] 41 | type PatternList SystemFwTag = '[] 42 | type TermList SystemFwTag = '[TmFLam, TmFApp, TmFSystemF] 43 | 44 | instance NormalizeRules SystemFwTag where 45 | type NormalizeConstraint ki ty a SystemFwTag = 46 | SystemFwNormalizeConstraint ki ty a 47 | 48 | normalizeInput _ = 49 | systemFwNormalizeRules 50 | 51 | instance MkInferKind i => InferKindRules i SystemFwTag where 52 | type InferKindConstraint e w s r m ki ty a i SystemFwTag = 53 | SystemFwInferKindConstraint e w s r m ki ty a i 54 | type InferKindErrorList ki ty a i SystemFwTag = 55 | '[] 56 | type InferKindWarningList ki ty a i SystemFwTag = 57 | '[] 58 | 59 | inferKindInput m i _ = 60 | systemFwInferKindInput m i 61 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.SystemFw.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.SystemFw.Ast.Type as X 13 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | module Fragment.SystemFw.Ast.Error ( 14 | ErrExpectedTyLamAnnotation(..) 15 | , AsExpectedTyLamAnnotation(..) 16 | ) where 17 | 18 | import Control.Lens.Prism (Prism') 19 | import Control.Lens.TH (makePrisms) 20 | 21 | import Ast.Error 22 | 23 | data ErrExpectedTyLamAnnotation = ErrExpectedTyLamAnnotation 24 | deriving (Eq, Ord, Show) 25 | 26 | makePrisms ''ErrExpectedTyLamAnnotation 27 | 28 | class AsExpectedTyLamAnnotation e where -- | e -> ty, e -> a where 29 | _ExpectedTyLamAnnotation :: Prism' e () 30 | 31 | instance AsExpectedTyLamAnnotation ErrExpectedTyLamAnnotation where 32 | _ExpectedTyLamAnnotation = _ErrExpectedTyLamAnnotation 33 | 34 | instance {-# OVERLAPPABLE #-} AsExpectedTyLamAnnotation (ErrSum xs) => AsExpectedTyLamAnnotation (ErrSum (x ': xs)) where 35 | _ExpectedTyLamAnnotation = _ErrNext . _ExpectedTyLamAnnotation 36 | 37 | instance {-# OVERLAPPING #-} AsExpectedTyLamAnnotation (ErrSum (ErrExpectedTyLamAnnotation ': xs)) where 38 | _ExpectedTyLamAnnotation = _ErrNow . _ExpectedTyLamAnnotation 39 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Ast/Kind.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE DeriveFunctor #-} 9 | {-# LANGUAGE DeriveFoldable #-} 10 | {-# LANGUAGE DeriveTraversable #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE FlexibleContexts #-} 13 | {-# LANGUAGE MultiParamTypeClasses #-} 14 | {-# LANGUAGE KindSignatures #-} 15 | {-# LANGUAGE TypeOperators #-} 16 | {-# LANGUAGE DataKinds #-} 17 | {-# LANGUAGE TemplateHaskell #-} 18 | module Fragment.SystemFw.Ast.Kind ( 19 | KiFSystemFw 20 | , AsKiSystemFw(..) 21 | ) where 22 | 23 | import Control.Lens.Prism (Prism') 24 | import Control.Lens.Wrapped (_Wrapped) 25 | import Control.Lens.TH (makePrisms) 26 | import Data.Deriving (deriveEq1, deriveOrd1, deriveShow1) 27 | 28 | import Ast.Kind 29 | 30 | data KiFSystemFw f = 31 | KiArrF f f 32 | deriving (Eq, Ord, Show) 33 | 34 | makePrisms ''KiFSystemFw 35 | 36 | deriveEq1 ''KiFSystemFw 37 | deriveOrd1 ''KiFSystemFw 38 | deriveShow1 ''KiFSystemFw 39 | 40 | class AsKiSystemFw ki where 41 | _KiSystemFwP :: Prism' (ki j) (KiFSystemFw j) 42 | 43 | _KiArr :: Prism' (Kind ki) (Kind ki, Kind ki) 44 | _KiArr = _Wrapped . _KiSystemFwP . _KiArrF 45 | 46 | instance AsKiSystemFw KiFSystemFw where 47 | _KiSystemFwP = id 48 | 49 | instance {-# OVERLAPPABLE #-} AsKiSystemFw (KiSum xs) => AsKiSystemFw (KiSum (x ': xs)) where 50 | _KiSystemFwP = _KiNext . _KiSystemFwP 51 | 52 | instance {-# OVERLAPPING #-} AsKiSystemFw (KiSum (KiFSystemFw ': xs)) where 53 | _KiSystemFwP = _KiNow . _KiSystemFwP 54 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.SystemFw.Helpers ( 9 | tyLam 10 | , tyLamAnn 11 | , tyLamNoAnn 12 | , tyApp 13 | ) where 14 | 15 | import Control.Lens (review) 16 | 17 | import Ast.Kind 18 | import Ast.Type 19 | 20 | import Fragment.SystemFw.Ast.Type 21 | 22 | tyLam :: (Eq a, AsTySystemFw ki ty) => a -> Maybe (Kind ki a) -> Type ki ty a -> Type ki ty a 23 | tyLam v ki ty = review _TyLam (ki, abstractTy v ty) 24 | 25 | tyLamAnn :: (Eq a, AsTySystemFw ki ty) => a -> Kind ki a -> Type ki ty a -> Type ki ty a 26 | tyLamAnn v ki ty = review _TyLamAnn (ki, abstractTy v ty) 27 | 28 | tyLamNoAnn :: (Eq a, AsTySystemFw ki ty) => a -> Type ki ty a -> Type ki ty a 29 | tyLamNoAnn v ty = review _TyLamNoAnn (abstractTy v ty) 30 | 31 | tyApp :: AsTySystemFw ki ty => Type ki ty a -> Type ki ty a -> Type ki ty a 32 | tyApp = curry $ review _TyApp 33 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.SystemFw.Rules ( 12 | RSystemFw 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Error.Common 19 | import Context.Type.Error 20 | import Rules 21 | 22 | import Fragment.SystemFw.Ast 23 | import Fragment.SystemFw.Rules.Kind.Infer.SyntaxDirected 24 | import Fragment.SystemFw.Rules.Type.Infer.SyntaxDirected 25 | 26 | data RSystemFw 27 | 28 | instance AstIn RSystemFw where 29 | type KindList RSystemFw = '[KiFSystemFw] 30 | type TypeList RSystemFw = '[TyFSystemFw] 31 | type PatternList RSystemFw = '[] 32 | type TermList RSystemFw = '[TmFSystemFw] 33 | 34 | instance RulesIn RSystemFw where 35 | type InferKindContextSyntax e w s r m ki ty a RSystemFw = SystemFwInferKindContext e w s r m ki ty a 36 | type InferTypeContextSyntax e w s r m ki ty pt tm a RSystemFw = SystemFwInferTypeContext e w s r m ki ty pt tm a 37 | type InferTypeContextOffline e w s r m ki ty pt tm a RSystemFw = (() :: Constraint) 38 | type ErrorList ki ty pt tm a RSystemFw = '[ErrUnexpectedKind ki, ErrExpectedKiArr ki, ErrExpectedKindEq ki, ErrExpectedTyArr ki ty a, ErrExpectedTyAll ki ty a, ErrUnboundTypeVariable a] 39 | type WarningList ki ty pt tm a RSystemFw = '[] 40 | 41 | inferKindInputSyntax _ = systemFwInferKindRules 42 | inferTypeInputSyntax _ = systemFwInferTypeRules 43 | inferTypeInputOffline _ = mempty 44 | -------------------------------------------------------------------------------- /src/Fragment/SystemFw/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | module Fragment.SystemFw.Rules.Type ( 11 | SystemFwNormalizeConstraint 12 | , systemFwNormalizeRules 13 | ) where 14 | 15 | import Bound (toScope, fromScope) 16 | import Control.Lens (review, preview) 17 | 18 | import Rules.Type 19 | import Ast.Type 20 | 21 | import Fragment.SystemFw.Ast.Type 22 | 23 | type SystemFwNormalizeConstraint ki ty a = AsTySystemFw ki ty 24 | 25 | normalizeLam :: SystemFwNormalizeConstraint ki ty a 26 | => (forall b. Type ki ty b -> Type ki ty b) 27 | -> Type ki ty a 28 | -> Maybe (Type ki ty a) 29 | normalizeLam normalizeFn ty = do 30 | (k, s) <- preview _TyLam ty 31 | return $ review _TyLam (k, scopeAppTy normalizeFn s) 32 | 33 | normalizeApp :: SystemFwNormalizeConstraint ki ty a 34 | => (Type ki ty a -> Type ki ty a) 35 | -> Type ki ty a 36 | -> Maybe (Type ki ty a) 37 | normalizeApp normalizeFn ty = do 38 | (ty1, ty2) <- preview _TyApp ty 39 | return $ review _TyApp (normalizeFn ty1, normalizeFn ty2) 40 | 41 | systemFwNormalizeRules :: SystemFwNormalizeConstraint ki ty a 42 | => NormalizeInput ki ty a 43 | systemFwNormalizeRules = 44 | NormalizeInput 45 | [ NormalizeTypeRecurse normalizeLam 46 | , NormalizeTypeRecurse normalizeApp 47 | ] 48 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TmApp.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TmApp.Ast.Term as X 13 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TmApp.Helpers ( 9 | tmApp 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Term 15 | 16 | import Fragment.TmApp.Ast.Term 17 | 18 | tmApp :: AsTmApp ki ty pt tm => Term ki ty pt tm a -> Term ki ty pt tm a -> Term ki ty pt tm a 19 | tmApp = curry $ review _TmApp 20 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmApp.Rules ( 12 | RTmApp 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Context.Type.Error 19 | import Rules 20 | 21 | import Fragment.TmApp.Ast 22 | import qualified Fragment.TmApp.Rules.Type.Infer.SyntaxDirected as TSD 23 | import qualified Fragment.TmApp.Rules.Type.Infer.Offline as TUO 24 | 25 | data RTmApp 26 | 27 | instance AstIn RTmApp where 28 | type KindList RTmApp = '[] 29 | type TypeList RTmApp = '[] 30 | type PatternList RTmApp = '[] 31 | type TermList RTmApp = '[TmFApp] 32 | 33 | instance RulesIn RTmApp where 34 | type InferKindContextSyntax e w s r m ki ty a RTmApp = (() :: Constraint) 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTmApp = TSD.TmAppInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RTmApp = TUO.TmAppInferTypeContext e w s r m ki ty pt tm a 37 | type ErrorList ki ty pt tm a RTmApp = '[ErrUnboundTypeVariable a] 38 | type WarningList ki ty pt tm a RTmApp = '[] 39 | 40 | inferKindInputSyntax _ = mempty 41 | inferTypeInputSyntax _ = TSD.tmAppInferTypeRules 42 | inferTypeInputOffline _ = TUO.tmAppInferTypeRules 43 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.TmApp.Rules.Term ( 10 | TmAppEvalConstraint 11 | , tmAppEvalRulesStrict 12 | , tmAppEvalRulesLazy 13 | ) where 14 | 15 | import Control.Lens (review, preview) 16 | 17 | import Rules.Term 18 | import Ast.Term 19 | 20 | import Fragment.TmApp.Ast.Term 21 | 22 | stepTmApp1 :: AsTmApp ki ty pt tm => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 23 | stepTmApp1 evalFn tm = do 24 | (f, x) <- preview _TmApp tm 25 | f' <- evalFn f 26 | return $ review _TmApp (f', x) 27 | 28 | stepTmApp2 :: AsTmApp ki ty pt tm => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 29 | stepTmApp2 valueFn stepFn tm = do 30 | (tmF, tmX) <- preview _TmApp tm 31 | vF <- valueFn tmF 32 | tmX' <- stepFn tmX 33 | return $ review _TmApp (vF, tmX') 34 | 35 | type TmAppEvalConstraint ki ty pt tm a = 36 | AsTmApp ki ty pt tm 37 | 38 | tmAppEvalRulesStrict :: TmAppEvalConstraint ki ty pt tm a 39 | => EvalInput ki ty pt tm a 40 | tmAppEvalRulesStrict = 41 | EvalInput 42 | [] 43 | [ StepRecurse stepTmApp1 44 | , StepValueRecurse stepTmApp2 45 | ] 46 | [] 47 | 48 | tmAppEvalRulesLazy :: TmAppEvalConstraint ki ty pt tm a 49 | => EvalInput ki ty pt tm a 50 | tmAppEvalRulesLazy = 51 | EvalInput 52 | [] 53 | [ StepRecurse stepTmApp1 ] 54 | [] 55 | 56 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.TmApp.Rules.Type.Infer.Offline ( 11 | TmAppInferTypeContext 12 | , tmAppInferTypeRules 13 | ) where 14 | 15 | import Control.Lens (review) 16 | import Control.Monad.State (MonadState) 17 | 18 | import Ast.Type 19 | import Ast.Type.Var 20 | import Data.Functor.Rec 21 | import Rules.Type.Infer.Offline 22 | 23 | import Fragment.TyArr.Ast.Type 24 | 25 | import qualified Fragment.TmApp.Rules.Type.Infer.Common as A 26 | 27 | expectTyArr :: (Eq a, EqRec (ty ki), MonadState s m, HasTyVarSupply s, ToTyVar a, AsTyArr ki ty) 28 | => Type ki ty a 29 | -> UnifyT ki ty a m (Type ki ty a, Type ki ty a) 30 | expectTyArr ty = do 31 | tyArg <- fmap (review _TyVar) freshTyVar 32 | tyRet <- fmap (review _TyVar) freshTyVar 33 | let tyArr = review _TyArr (tyArg, tyRet) 34 | expectTypeEq ty tyArr 35 | return (tyArg, tyRet) 36 | 37 | 38 | type TmAppInferTypeContext e w s r m ki ty pt tm a = 39 | ( A.TmAppInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 40 | , Eq a 41 | , EqRec (ty ki) 42 | , MonadState s m 43 | , HasTyVarSupply s 44 | , ToTyVar a 45 | , AsTyArr ki ty 46 | ) 47 | 48 | tmAppInferTypeRules :: TmAppInferTypeContext e w s r m ki ty pt tm a 49 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 50 | tmAppInferTypeRules = 51 | let 52 | ah = A.TmAppHelper expectTyArr expectTypeEq 53 | in 54 | A.inferTypeInput ah 55 | -------------------------------------------------------------------------------- /src/Fragment/TmApp/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.TmApp.Rules.Type.Infer.SyntaxDirected ( 11 | TmAppInferTypeContext 12 | , tmAppInferTypeRules 13 | ) where 14 | 15 | import Control.Monad.Except (MonadError) 16 | 17 | import Ast.Error.Common 18 | import Data.Functor.Rec 19 | import Rules.Type.Infer.SyntaxDirected 20 | 21 | import Fragment.TyArr.Ast.Error 22 | 23 | import qualified Fragment.TmApp.Rules.Type.Infer.Common as A 24 | 25 | type TmAppInferTypeContext e w s r m ki ty pt tm a = 26 | ( A.TmAppInferTypeContext e w s r m m ki ty pt tm a 27 | , Eq a 28 | , EqRec (ty ki) 29 | , MonadError e m 30 | , AsExpectedTyArr e ki ty a 31 | , AsExpectedTypeEq e ki ty a 32 | ) 33 | 34 | tmAppInferTypeRules :: TmAppInferTypeContext e w s r m ki ty pt tm a 35 | => InferTypeInput e w s r m m ki ty pt tm a 36 | tmAppInferTypeRules = 37 | let 38 | ah = A.TmAppHelper expectTyArr expectTypeEq 39 | in 40 | A.inferTypeInput ah 41 | -------------------------------------------------------------------------------- /src/Fragment/TmLam.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.TmLam ( 13 | module X 14 | , TmLamTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Rules.Type 21 | import Rules.Type.Infer.Common 22 | import Rules.Term 23 | import Fragment.TyArr.Ast.Type 24 | 25 | import Fragment.TmLam.Ast as X 26 | import Fragment.TmLam.Helpers as X 27 | 28 | import Fragment.TmLam.Rules.Type.Infer.Common 29 | import Fragment.TmLam.Rules.Term 30 | 31 | data TmLamTag 32 | 33 | instance AstIn TmLamTag where 34 | type KindList TmLamTag = '[] 35 | type TypeList TmLamTag = '[TyFArr] 36 | type TypeSchemeList TmLamTag = '[] 37 | type PatternList TmLamTag = '[] 38 | type TermList TmLamTag = '[TmFLam] 39 | 40 | instance EvalRules e TmLamTag where 41 | type EvalConstraint ki ty pt tm a e TmLamTag = 42 | TmLamEvalConstraint ki ty pt tm a 43 | 44 | evalInput _ _ = 45 | tmLamEvalRules 46 | 47 | instance NormalizeRules TmLamTag where 48 | type NormalizeConstraint ki ty a TmLamTag = 49 | (() :: Constraint) 50 | 51 | normalizeInput _ = 52 | mempty 53 | 54 | instance MkInferType i => InferTypeRules i TmLamTag where 55 | type InferTypeConstraint e w s r m ki ty pt tm a i TmLamTag = 56 | TmLamInferTypeConstraint e w s r m ki ty pt tm a i 57 | type InferTypeErrorList ki ty pt tm a i TmLamTag = 58 | '[ ErrExpectedTmLamAnnotation ] 59 | type InferTypeWarningList ki ty pt tm a i TmLamTag = 60 | '[] 61 | 62 | inferTypeInput m i _ = 63 | tmLamInferTypeInput m i 64 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TmLam.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TmLam.Ast.Error as X 13 | import Fragment.TmLam.Ast.Term as X 14 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE FlexibleInstances #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TemplateHaskell #-} 13 | module Fragment.TmLam.Ast.Error ( 14 | ErrExpectedTmLamAnnotation(..) 15 | , AsExpectedTmLamAnnotation(..) 16 | ) where 17 | 18 | import Control.Lens.Prism (Prism') 19 | import Control.Lens.TH (makePrisms) 20 | 21 | import Ast.Error 22 | 23 | data ErrExpectedTmLamAnnotation = ErrExpectedTmLamAnnotation 24 | deriving (Eq, Ord, Show) 25 | 26 | makePrisms ''ErrExpectedTmLamAnnotation 27 | 28 | class AsExpectedTmLamAnnotation e where -- | e -> ty, e -> a where 29 | _ExpectedTmLamAnnotation :: Prism' e () 30 | 31 | instance AsExpectedTmLamAnnotation ErrExpectedTmLamAnnotation where 32 | _ExpectedTmLamAnnotation = _ErrExpectedTmLamAnnotation 33 | 34 | instance {-# OVERLAPPABLE #-} AsExpectedTmLamAnnotation (ErrSum xs) => AsExpectedTmLamAnnotation (ErrSum (x ': xs)) where 35 | _ExpectedTmLamAnnotation = _ErrNext . _ExpectedTmLamAnnotation 36 | 37 | instance {-# OVERLAPPING #-} AsExpectedTmLamAnnotation (ErrSum (ErrExpectedTmLamAnnotation ': xs)) where 38 | _ExpectedTmLamAnnotation = _ErrNow . _ExpectedTmLamAnnotation 39 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TmLam.Helpers ( 9 | tmLam 10 | , tmLamAnn 11 | , tmLamNoAnn 12 | ) where 13 | 14 | import Bound (abstract1) 15 | import Control.Lens (review) 16 | import Control.Lens.Wrapped (_Unwrapped) 17 | 18 | import Ast.Type 19 | import Ast.Term 20 | 21 | import Fragment.TmLam.Ast.Term 22 | 23 | tmLam :: (Eq a, AsTmLam ki ty pt tm) => a -> Maybe (Type ki ty a) -> Term ki ty pt tm a -> Term ki ty pt tm a 24 | tmLam v ty tm = review _TmLam (ty, abstract1 (review _TmAstTmVar v) . review _Unwrapped $ tm) 25 | 26 | tmLamAnn :: (Eq a, AsTmLam ki ty pt tm) => a -> Type ki ty a -> Term ki ty pt tm a -> Term ki ty pt tm a 27 | tmLamAnn v ty tm = review _TmLamAnn (ty, abstract1 (review _TmAstTmVar v) . review _Unwrapped $ tm) 28 | 29 | tmLamNoAnn :: (Eq a, AsTmLam ki ty pt tm) => a -> Term ki ty pt tm a -> Term ki ty pt tm a 30 | tmLamNoAnn v tm = review _TmLamNoAnn (abstract1 (review _TmAstTmVar v) . review _Unwrapped $ tm) 31 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmLam.Rules ( 12 | RTmLam 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Context.Type.Error 19 | import Rules 20 | 21 | import Fragment.TyArr.Ast.Type 22 | 23 | import Fragment.TmLam.Ast 24 | import qualified Fragment.TmLam.Rules.Type.Infer.SyntaxDirected as TSD 25 | import qualified Fragment.TmLam.Rules.Type.Infer.Offline as TUO 26 | 27 | data RTmLam 28 | 29 | instance AstIn RTmLam where 30 | type KindList RTmLam = '[] 31 | type TypeList RTmLam = '[TyFArr] 32 | type PatternList RTmLam = '[] 33 | type TermList RTmLam = '[TmFLam] 34 | 35 | instance RulesIn RTmLam where 36 | type InferKindContextSyntax e w s r m ki ty a RTmLam = (() :: Constraint) 37 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTmLam = TSD.TmLamInferTypeContext e w s r m ki ty pt tm a 38 | type InferTypeContextOffline e w s r m ki ty pt tm a RTmLam = TUO.TmLamInferTypeContext e w s r m ki ty pt tm a 39 | type ErrorList ki ty pt tm a RTmLam = '[ErrExpectedTmLamAnnotation, ErrUnboundTypeVariable a] 40 | type WarningList ki ty pt tm a RTmLam = '[] 41 | 42 | inferKindInputSyntax _ = mempty 43 | inferTypeInputSyntax _ = TSD.tmLamInferTypeRules 44 | inferTypeInputOffline _ = TUO.tmLamInferTypeRules 45 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.TmLam.Rules.Term ( 10 | TmLamEvalConstraint 11 | , tmLamEvalRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Term 17 | import Ast.Term 18 | 19 | import Fragment.TmLam.Ast.Term 20 | 21 | valTmLam :: AsTmLam ki ty pt tm => Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 22 | valTmLam tm = do 23 | _ <- preview _TmLam tm 24 | return tm 25 | 26 | type TmLamEvalConstraint ki ty pt tm a = 27 | AsTmLam ki ty pt tm 28 | 29 | tmLamEvalRules :: TmLamEvalConstraint ki ty pt tm a 30 | => EvalInput ki ty pt tm a 31 | tmLamEvalRules = 32 | EvalInput 33 | [ ValueBase valTmLam ] 34 | [] 35 | [] 36 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmLam.Rules.Type.Infer.Offline ( 12 | TmLamInferTypeContext 13 | , tmLamInferTypeRules 14 | ) where 15 | 16 | import Bound (Scope) 17 | import Control.Lens (review, preview) 18 | 19 | import Control.Monad.State (MonadState) 20 | 21 | import Ast.Type 22 | import Ast.Type.Var 23 | import Ast.Error.Common 24 | import Ast.Term 25 | import Data.Functor.Rec 26 | import Rules.Type.Infer.Offline 27 | 28 | 29 | import Fragment.TmLam.Ast.Term 30 | 31 | import qualified Fragment.TmLam.Rules.Type.Infer.Common as L 32 | 33 | type TmLamInferTypeContext e w s r m ki ty pt tm a = 34 | ( L.TmLamInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 35 | , Eq a 36 | , EqRec (ty ki) 37 | , MonadState s m 38 | , HasTyVarSupply s 39 | , ToTyVar a 40 | ) 41 | 42 | expectTmLam :: TmLamInferTypeContext e w s r m ki ty pt tm a 43 | => Term ki ty pt tm a 44 | -> Maybe (UnifyT ki ty a m (Type ki ty a, Scope () (Ast ki ty pt tm) (AstVar a))) 45 | expectTmLam tm = do 46 | (mty, s) <- preview _TmLam tm 47 | return $ do 48 | tyV <- fmap (review _TyVar) freshTyVar 49 | case mty of 50 | Nothing -> return () 51 | Just ty -> expectType (ExpectedType ty) (ActualType tyV) 52 | return (tyV, s) 53 | 54 | tmLamInferTypeRules :: TmLamInferTypeContext e w s r m ki ty pt tm a 55 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 56 | tmLamInferTypeRules = 57 | L.inferTypeInput (L.TmLamHelper expectTmLam) 58 | -------------------------------------------------------------------------------- /src/Fragment/TmLam/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmLam.Rules.Type.Infer.SyntaxDirected ( 12 | TmLamInferTypeContext 13 | , tmLamInferTypeRules 14 | ) where 15 | 16 | import Bound (Scope) 17 | import Control.Lens (preview) 18 | import Control.Monad.Except (MonadError) 19 | import Control.Monad.Error.Lens (throwing) 20 | 21 | import Ast.Type 22 | import Ast.Term 23 | import Rules.Type.Infer.SyntaxDirected 24 | 25 | import Fragment.TmLam.Ast.Error 26 | import Fragment.TmLam.Ast.Term 27 | 28 | import qualified Fragment.TmLam.Rules.Type.Infer.Common as L 29 | 30 | type TmLamInferTypeContext e w s r m ki ty pt tm a = 31 | ( L.TmLamInferTypeContext e w s r m m ki ty pt tm a 32 | , MonadError e m 33 | , AsExpectedTmLamAnnotation e 34 | ) 35 | 36 | expectTmLam :: TmLamInferTypeContext e w s r m ki ty pt tm a 37 | => Term ki ty pt tm a 38 | -> Maybe (m (Type ki ty a, Scope () (Ast ki ty pt tm) (AstVar a))) 39 | expectTmLam tm = do 40 | (mty, s) <- preview _TmLam tm 41 | return $ do 42 | case mty of 43 | Nothing -> throwing _ExpectedTmLamAnnotation () 44 | Just ty -> return (ty, s) 45 | 46 | tmLamInferTypeRules :: TmLamInferTypeContext e w s r m ki ty pt tm a 47 | => InferTypeInput e w s r m m ki ty pt tm a 48 | tmLamInferTypeRules = 49 | let 50 | lh = L.TmLamHelper expectTmLam 51 | in 52 | L.inferTypeInput lh 53 | -------------------------------------------------------------------------------- /src/Fragment/TmVar.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.TmVar ( 13 | module X 14 | , TmVarTag 15 | ) where 16 | 17 | import GHC.Exts (Constraint) 18 | 19 | import Ast 20 | import Context.Term.Error 21 | import Rules.Type 22 | import Rules.Type.Infer.Common 23 | import Rules.Term 24 | 25 | import Fragment.TmVar.Helpers as X 26 | 27 | import Fragment.TmVar.Rules.Type.Infer.Common 28 | 29 | data TmVarTag 30 | 31 | instance AstIn TmVarTag where 32 | type KindList TmVarTag = '[] 33 | type TypeList TmVarTag = '[] 34 | type TypeSchemeList TmVarTag = '[] 35 | type PatternList TmVarTag = '[] 36 | type TermList TmVarTag = '[] 37 | 38 | instance EvalRules e TmVarTag where 39 | type EvalConstraint ki ty pt tm a e TmVarTag = 40 | (() :: Constraint) 41 | 42 | evalInput _ _ = 43 | mempty 44 | 45 | instance NormalizeRules TmVarTag where 46 | type NormalizeConstraint ki ty a TmVarTag = 47 | (() :: Constraint) 48 | 49 | normalizeInput _ = 50 | mempty 51 | 52 | instance MkInferType i => InferTypeRules i TmVarTag where 53 | type InferTypeConstraint e w s r m ki ty pt tm a i TmVarTag = 54 | TmVarInferTypeConstraint e w s r m ki ty pt tm a i 55 | type InferTypeErrorList ki ty pt tm a i TmVarTag = 56 | '[ErrUnboundTermVariable a] 57 | type InferTypeWarningList ki ty pt tm a i TmVarTag = 58 | '[] 59 | 60 | inferTypeInput m i _ = 61 | tmVarInferTypeInput m i 62 | -------------------------------------------------------------------------------- /src/Fragment/TmVar/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TmVar.Helpers ( 9 | tmVar 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Term 15 | 16 | tmVar :: a -> Term ki ty pt tm a 17 | tmVar = review _TmVar 18 | -------------------------------------------------------------------------------- /src/Fragment/TmVar/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmVar.Rules ( 12 | RTmVar 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Context.Term.Error 19 | import Rules 20 | 21 | import qualified Fragment.TmVar.Rules.Type.Infer.SyntaxDirected as SD 22 | import qualified Fragment.TmVar.Rules.Type.Infer.Offline as UO 23 | 24 | data RTmVar 25 | 26 | instance AstIn RTmVar where 27 | type KindList RTmVar = '[] 28 | type TypeList RTmVar = '[] 29 | type PatternList RTmVar = '[] 30 | type TermList RTmVar = '[] 31 | 32 | instance RulesIn RTmVar where 33 | type InferKindContextSyntax e w s r m ki ty a RTmVar = (() :: Constraint) 34 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTmVar = SD.TmVarInferTypeContext e w s r m ki ty pt tm a 35 | type InferTypeContextOffline e w s r m ki ty pt tm a RTmVar = UO.TmVarInferTypeContext e w s r m ki ty pt tm a 36 | type ErrorList ki ty tm pt a RTmVar = '[ErrUnboundTermVariable a] 37 | type WarningList ki ty tm pt a RTmVar = '[] 38 | 39 | inferKindInputSyntax _ = mempty 40 | inferTypeInputSyntax _ = SD.tmVarInferTypeRules 41 | inferTypeInputOffline _ = UO.tmVarInferTypeRules 42 | -------------------------------------------------------------------------------- /src/Fragment/TmVar/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | module Fragment.TmVar.Rules.Type.Infer.Common ( 12 | TmVarInferTypeConstraint 13 | , tmVarInferTypeInput 14 | ) where 15 | 16 | import Data.Proxy (Proxy) 17 | 18 | import Control.Monad.Reader (MonadReader) 19 | import Control.Monad.Except (MonadError) 20 | import Control.Lens (preview) 21 | 22 | import Ast.Type 23 | import Ast.Term 24 | import Context.Term 25 | 26 | import Rules.Type.Infer.Common 27 | 28 | type TmVarInferTypeConstraint e w s r m ki ty pt tm a i = 29 | ( BasicInferTypeConstraint e w s r m ki ty pt tm a i 30 | , Ord a 31 | , MonadReader r (InferTypeMonad m ki ty a i) 32 | , HasTermContext r ki ty a 33 | , MonadError e (InferTypeMonad m ki ty a i) 34 | , AsUnboundTermVariable e a 35 | ) 36 | 37 | inferTmVar :: TmVarInferTypeConstraint e w s r m ki ty pt tm a i 38 | => Proxy (MonadProxy e w s r m) 39 | -> Proxy i 40 | -> Term ki ty pt tm a 41 | -> Maybe (InferTypeMonad m ki ty a i (Type ki ty a)) 42 | inferTmVar _ _ tm = do 43 | v <- preview _TmVar tm 44 | return $ lookupTerm v 45 | 46 | tmVarInferTypeInput :: TmVarInferTypeConstraint e w s r m ki ty pt tm a i 47 | => Proxy (MonadProxy e w s r m) 48 | -> Proxy i 49 | -> InferTypeInput e w s r m (InferTypeMonad m ki ty a i) ki ty pt tm a 50 | tmVarInferTypeInput m i = 51 | InferTypeInput [] [ InferTypeBase $ inferTmVar m i ] [] 52 | -------------------------------------------------------------------------------- /src/Fragment/TmVar/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TmVar.Rules.Type.Infer.Offline ( 12 | TmVarInferTypeContext 13 | , tmVarInferTypeRules 14 | ) where 15 | 16 | import Control.Monad.Reader (MonadReader) 17 | import Control.Monad.Except (MonadError) 18 | 19 | import Rules.Type.Infer.Offline 20 | import Context.Term 21 | 22 | import Fragment.TmVar.Rules.Type.Infer.Common 23 | 24 | type TmVarInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, Ord a, MonadReader r m, HasTermContext r ki ty a, MonadError e m, AsUnboundTermVariable e a) 25 | 26 | tmVarInferTypeRules :: TmVarInferTypeContext e w s r m ki ty pt tm a 27 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 28 | tmVarInferTypeRules = 29 | inferTypeInput 30 | -------------------------------------------------------------------------------- /src/Fragment/TmVar/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Fragment.TmVar.Rules.Type.Infer.SyntaxDirected ( 11 | TmVarInferTypeContext 12 | , tmVarInferTypeRules 13 | ) where 14 | 15 | import Control.Monad.Reader (MonadReader) 16 | import Control.Monad.Except (MonadError) 17 | 18 | import Rules.Type.Infer.SyntaxDirected 19 | import Context.Term 20 | 21 | import Fragment.TmVar.Rules.Type.Infer.Common 22 | 23 | type TmVarInferTypeContext e w s r m ki ty pt tm a = (InferTypeContext e w s r m ki ty pt tm a, Ord a, MonadReader r m, HasTermContext r ki ty a, MonadError e m, AsUnboundTermVariable e a) 24 | 25 | tmVarInferTypeRules :: TmVarInferTypeContext e w s r m ki ty pt tm a 26 | => InferTypeInput e w s r m m ki ty pt tm a 27 | tmVarInferTypeRules = 28 | inferTypeInput 29 | 30 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Tuple.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Tuple.Ast.Type as X 13 | import Fragment.Tuple.Ast.Error as X 14 | import Fragment.Tuple.Ast.Pattern as X 15 | import Fragment.Tuple.Ast.Term as X 16 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Tuple.Helpers ( 9 | tyTuple 10 | , ptTuple 11 | , tmTuple 12 | , tmTupleIx 13 | ) where 14 | 15 | import Control.Lens (review) 16 | 17 | import Ast.Type 18 | import Ast.Pattern 19 | import Ast.Term 20 | 21 | import Fragment.Tuple.Ast.Type 22 | import Fragment.Tuple.Ast.Pattern 23 | import Fragment.Tuple.Ast.Term 24 | 25 | tyTuple :: AsTyTuple ki ty => [Type ki ty a] -> Type ki ty a 26 | tyTuple = review _TyTuple 27 | 28 | ptTuple :: AsPtTuple pt => [Pattern pt a] -> Pattern pt a 29 | ptTuple = review _PtTuple 30 | 31 | tmTuple :: AsTmTuple ki ty pt tm => [Term ki ty pt tm a] -> Term ki ty pt tm a 32 | tmTuple = review _TmTuple 33 | 34 | tmTupleIx :: AsTmTuple ki ty pt tm => Term ki ty pt tm a -> Int -> Term ki ty pt tm a 35 | tmTupleIx = curry $ review _TmTupleIx 36 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Tuple.Rules ( 12 | RTuple 13 | ) where 14 | 15 | import Ast 16 | import Rules 17 | 18 | import Fragment.KiBase.Ast.Kind 19 | 20 | import Fragment.Tuple.Ast 21 | import qualified Fragment.Tuple.Rules.Kind.Infer.SyntaxDirected as KSD 22 | import qualified Fragment.Tuple.Rules.Type.Infer.SyntaxDirected as TSD 23 | import qualified Fragment.Tuple.Rules.Type.Infer.Offline as TUO 24 | 25 | data RTuple 26 | 27 | instance AstIn RTuple where 28 | type KindList RTuple = '[KiFBase] 29 | type TypeList RTuple = '[TyFTuple] 30 | type PatternList RTuple = '[PtFTuple] 31 | type TermList RTuple = '[TmFTuple] 32 | 33 | instance RulesIn RTuple where 34 | type InferKindContextSyntax e w s r m ki ty a RTuple = KSD.TupleInferKindContext e w s r m ki ty a 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTuple = TSD.TupleInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RTuple = TUO.TupleInferTypeContext e w s r m ki ty pt tm a 37 | type ErrorList ki ty pt tm a RTuple = '[ErrExpectedTyTuple ki ty a, ErrTupleOutOfBounds] 38 | type WarningList ki ty pt tm a RTuple = '[] 39 | 40 | inferKindInputSyntax _ = KSD.tupleInferKindRules 41 | inferTypeInputSyntax _ = TSD.tupleInferTypeRules 42 | inferTypeInputOffline _ = TUO.tupleInferTypeRules 43 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.Tuple.Rules.Kind.Infer.Common ( 13 | TupleInferKindConstraint 14 | , tupleInferKindInput 15 | ) where 16 | 17 | import Data.Foldable (traverse_) 18 | import Data.Proxy (Proxy(..)) 19 | 20 | import Control.Lens (review, preview) 21 | 22 | import Ast.Kind 23 | import Ast.Type 24 | import Rules.Kind.Infer.Common 25 | 26 | import Fragment.KiBase.Ast.Kind 27 | import Fragment.Tuple.Ast.Type 28 | 29 | type TupleInferKindConstraint e w s r m ki ty a i = 30 | ( BasicInferKindConstraint e w s r m ki ty a i 31 | , AsKiBase ki 32 | , AsTyTuple ki ty 33 | ) 34 | 35 | tupleInferKindInput :: TupleInferKindConstraint e w s r m ki ty a i 36 | => Proxy (MonadProxy e w s r m) 37 | -> Proxy i 38 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 39 | tupleInferKindInput m i = 40 | InferKindInput 41 | [] 42 | [ InferKindRecurse $ inferTyTuple m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 43 | 44 | inferTyTuple :: TupleInferKindConstraint e w s r m ki ty a i 45 | => Proxy (MonadProxy e w s r m) 46 | -> Proxy ki 47 | -> Proxy ty 48 | -> Proxy a 49 | -> Proxy i 50 | -> (Type ki ty a -> InferKindMonad m ki a i (Kind ki a)) 51 | -> Type ki ty a 52 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 53 | inferTyTuple pm pki pty pa pi inferFn ty = do 54 | tys <- preview _TyTuple ty 55 | return $ do 56 | let kib = review _KiBase () 57 | traverse_ (\tyT -> mkCheckKind pm pki pty pa pi inferFn tyT kib) tys 58 | return kib 59 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Tuple.Rules.Kind.Infer.SyntaxDirected ( 10 | TupleInferKindContext 11 | , tupleInferKindRules 12 | ) where 13 | 14 | import Data.Foldable (traverse_) 15 | 16 | import Control.Lens (review, preview) 17 | import Control.Monad.Except (MonadError) 18 | import Data.Functor.Classes (Eq1) 19 | 20 | import Ast.Kind 21 | import Ast.Type 22 | import Ast.Error.Common 23 | import Rules.Kind.Infer.SyntaxDirected 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Tuple.Ast.Type 27 | 28 | inferTyTuple :: (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyTuple ki ty) 29 | => (Type ki ty a -> m (Kind ki)) 30 | -> Type ki ty a 31 | -> Maybe (m (Kind ki)) 32 | inferTyTuple inferFn ty = do 33 | tys <- preview _TyTuple ty 34 | return $ do 35 | let ki = review _KiBase() 36 | traverse_ (\tyT -> mkCheckKind inferFn tyT ki) tys 37 | return . review _KiBase $ () 38 | 39 | type TupleInferKindContext e w s r m ki ty a = (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyTuple ki ty) 40 | 41 | tupleInferKindRules :: TupleInferKindContext e w s r m ki ty a 42 | => InferKindInput e w s r m ki ty a 43 | tupleInferKindRules = 44 | InferKindInput 45 | [InferKindRecurse inferTyTuple] 46 | -------------------------------------------------------------------------------- /src/Fragment/Tuple/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Tuple.Rules.Type ( 10 | TupleNormalizeConstraint 11 | , tupleNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.Tuple.Ast.Type 20 | 21 | type TupleNormalizeConstraint ki ty a = AsTyTuple ki ty 22 | 23 | normalizeTuple :: TupleNormalizeConstraint ki ty a 24 | => (Type ki ty a -> Type ki ty a) 25 | -> Type ki ty a 26 | -> Maybe (Type ki ty a) 27 | normalizeTuple normalizeFn ty = do 28 | tys <- preview _TyTuple ty 29 | return $ review _TyTuple (fmap normalizeFn tys) 30 | 31 | tupleNormalizeRules :: TupleNormalizeConstraint ki ty a 32 | => NormalizeInput ki ty a 33 | tupleNormalizeRules = 34 | NormalizeInput [ NormalizeTypeRecurse normalizeTuple ] 35 | -------------------------------------------------------------------------------- /src/Fragment/TyAll.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE MultiParamTypeClasses #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | module Fragment.TyAll ( 13 | module X 14 | , TyAllTag 15 | ) where 16 | 17 | import Ast 18 | import Rules.Kind.Infer.Common 19 | import Rules.Type 20 | 21 | import Fragment.KiArr.Ast.Kind 22 | 23 | import Fragment.TyAll.Ast as X 24 | import Fragment.TyAll.Helpers as X 25 | 26 | import Fragment.TyAll.Rules.Kind.Infer.Common 27 | import Fragment.TyAll.Rules.Type 28 | 29 | data TyAllTag 30 | 31 | instance AstIn TyAllTag where 32 | type KindList TyAllTag = '[KiFArr] 33 | type TypeList TyAllTag = '[TyFAll] 34 | type TypeSchemeList TyAllTag = '[] 35 | type PatternList TyAllTag = '[] 36 | type TermList TyAllTag = '[] 37 | 38 | instance NormalizeRules TyAllTag where 39 | type NormalizeConstraint ki ty a TyAllTag = 40 | TyAllNormalizeConstraint ki ty a 41 | 42 | normalizeInput _ = 43 | tyAllNormalizeRules 44 | 45 | instance MkInferKind i => InferKindRules i TyAllTag where 46 | type InferKindConstraint e w s r m ki ty a i TyAllTag = 47 | TyAllInferKindConstraint e w s r m ki ty a i 48 | type InferKindErrorList ki ty a i TyAllTag = 49 | '[] 50 | type InferKindWarningList ki ty a i TyAllTag = 51 | '[] 52 | 53 | inferKindInput m i _ = 54 | tyAllInferKindInput m i 55 | -------------------------------------------------------------------------------- /src/Fragment/TyAll/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyAll.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TyAll.Ast.Type as X 13 | import Fragment.TyAll.Ast.Error as X 14 | -------------------------------------------------------------------------------- /src/Fragment/TyAll/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyAll.Helpers ( 9 | tyAll 10 | , tyAllAnn 11 | , tyAllNoAnn 12 | ) where 13 | 14 | import Control.Lens (review) 15 | 16 | import Ast.Kind 17 | import Ast.Type 18 | 19 | import Fragment.TyAll.Ast.Type 20 | 21 | tyAll :: (Eq a, AsTyAll ki ty) => a -> Maybe (Kind ki a) -> Type ki ty a -> Type ki ty a 22 | tyAll v ki ty = review _TyAll (ki, abstractTy v ty) 23 | 24 | tyAllAnn :: (Eq a, AsTyAll ki ty) => a -> Kind ki a -> Type ki ty a -> Type ki ty a 25 | tyAllAnn v ki ty = review _TyAllAnn (ki, abstractTy v ty) 26 | 27 | tyAllNoAnn :: (Eq a, AsTyAll ki ty) => a -> Type ki ty a -> Type ki ty a 28 | tyAllNoAnn v ty = review _TyAllNoAnn (abstractTy v ty) 29 | -------------------------------------------------------------------------------- /src/Fragment/TyAll/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | module Fragment.TyAll.Rules.Type ( 11 | TyAllNormalizeConstraint 12 | , tyAllNormalizeRules 13 | ) where 14 | 15 | import Control.Lens (review, preview) 16 | 17 | import Rules.Type 18 | import Ast.Type 19 | 20 | import Fragment.TyAll.Ast.Type 21 | 22 | type TyAllNormalizeConstraint ki ty a = AsTyAll ki ty 23 | 24 | normalizeAll :: TyAllNormalizeConstraint ki ty a 25 | => (forall b. Type ki ty b -> Type ki ty b) 26 | -> Type ki ty a 27 | -> Maybe (Type ki ty a) 28 | normalizeAll normalizeFn ty = do 29 | (k, s) <- preview _TyAll ty 30 | return $ review _TyAll (k, scopeAppTy normalizeFn s) 31 | 32 | tyAllNormalizeRules :: TyAllNormalizeConstraint ki ty a 33 | => NormalizeInput ki ty a 34 | tyAllNormalizeRules = 35 | NormalizeInput 36 | [ NormalizeTypeRecurse normalizeAll ] 37 | -------------------------------------------------------------------------------- /src/Fragment/TyAll/Rules/Type/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyAll.Rules.Type.Infer.Common ( 9 | ) where 10 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyArr.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.TyArr.Ast.Type as X 13 | import Fragment.TyArr.Ast.Error as X 14 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Ast/Error.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE FunctionalDependencies #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE FlexibleInstances #-} 12 | {-# LANGUAGE KindSignatures #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE DataKinds #-} 15 | {-# LANGUAGE TemplateHaskell #-} 16 | module Fragment.TyArr.Ast.Error ( 17 | ErrExpectedTyArr(..) 18 | , AsExpectedTyArr(..) 19 | , expectTyArr 20 | ) where 21 | 22 | import Control.Monad.Except (MonadError) 23 | import Control.Monad.Error.Lens (throwing) 24 | import Control.Lens (preview) 25 | import Control.Lens.Prism (Prism') 26 | import Control.Lens.TH (makePrisms) 27 | 28 | import Ast.Type 29 | import Ast.Error 30 | 31 | import Fragment.TyArr.Ast.Type 32 | 33 | data ErrExpectedTyArr ki ty a = ErrExpectedTyArr (Type ki ty a) 34 | deriving (Eq, Ord, Show) 35 | 36 | makePrisms ''ErrExpectedTyArr 37 | 38 | class AsExpectedTyArr e ki ty a where -- | e -> ty, e -> a where 39 | _ExpectedTyArr :: Prism' e (Type ki ty a) 40 | 41 | instance AsExpectedTyArr (ErrExpectedTyArr ki ty a) ki ty a where 42 | _ExpectedTyArr = _ErrExpectedTyArr 43 | 44 | instance {-# OVERLAPPABLE #-} AsExpectedTyArr (ErrSum xs) ki ty a => AsExpectedTyArr (ErrSum (x ': xs)) ki ty a where 45 | _ExpectedTyArr = _ErrNext . _ExpectedTyArr 46 | 47 | instance {-# OVERLAPPING #-} AsExpectedTyArr (ErrSum (ErrExpectedTyArr ki ty a ': xs)) ki ty a where 48 | _ExpectedTyArr = _ErrNow . _ExpectedTyArr 49 | 50 | expectTyArr :: (MonadError e m, AsExpectedTyArr e ki ty a, AsTyArr ki ty) => Type ki ty a -> m (Type ki ty a, Type ki ty a) 51 | expectTyArr ty = 52 | case preview _TyArr ty of 53 | Just (tyArg, tyRet) -> return (tyArg, tyRet) 54 | _ -> throwing _ExpectedTyArr ty 55 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyArr.Helpers ( 9 | tyArr 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Type 15 | 16 | import Fragment.TyArr.Ast.Type 17 | 18 | tyArr :: AsTyArr ki ty => Type ki ty a -> Type ki ty a -> Type ki ty a 19 | tyArr = curry $ review _TyArr 20 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TyArr.Rules ( 12 | RTyArr 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Ast.Error.Common 19 | import Rules 20 | 21 | import Fragment.TyArr.Ast 22 | import Fragment.TyArr.Rules.Kind.Infer.SyntaxDirected 23 | import Fragment.TyArr.Rules.Type.Infer.Offline 24 | 25 | data RTyArr 26 | 27 | instance AstIn RTyArr where 28 | type KindList RTyArr = '[] 29 | type TypeList RTyArr = '[TyFArr] 30 | type PatternList RTyArr = '[] 31 | type TermList RTyArr = '[] 32 | 33 | instance RulesIn RTyArr where 34 | type InferKindContextSyntax e w s r m ki ty a RTyArr = 35 | TyArrInferKindContext e w s r m ki ty a 36 | 37 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTyArr = 38 | (() :: Constraint) 39 | 40 | type InferTypeContextOffline e w s r m ki ty pt tm a RTyArr = 41 | TyArrInferTypeContext e w s r m ki ty pt tm a 42 | 43 | type ErrorList ki ty pt tm a RTyArr = '[ErrExpectedTyArr ki ty a, ErrUnexpectedKind ki] 44 | type WarningList ki ty pt tm a RTyArr = '[] 45 | 46 | inferKindInputSyntax _ = tyArrInferKindRules 47 | inferTypeInputSyntax _ = mempty 48 | inferTypeInputOffline _ = tyArrInferTypeRules 49 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | module Fragment.TyArr.Rules.Kind.Infer.Common ( 13 | TyArrInferKindConstraint 14 | , tyArrInferKindInput 15 | ) where 16 | 17 | import Data.Proxy (Proxy(..)) 18 | 19 | import Control.Lens (review, preview) 20 | 21 | import Ast.Kind 22 | import Ast.Type 23 | import Rules.Kind.Infer.Common 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.TyArr.Ast.Type 27 | 28 | type TyArrInferKindConstraint e w s r m ki ty a i = 29 | ( BasicInferKindConstraint e w s r m ki ty a i 30 | , AsKiBase ki 31 | , AsTyArr ki ty 32 | ) 33 | 34 | tyArrInferKindInput :: TyArrInferKindConstraint e w s r m ki ty a i 35 | => Proxy (MonadProxy e w s r m) 36 | -> Proxy i 37 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 38 | tyArrInferKindInput m i = 39 | InferKindInput 40 | [] 41 | [ InferKindRecurse $ inferTyArr m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 42 | 43 | inferTyArr :: TyArrInferKindConstraint e w s r m ki ty a i 44 | => Proxy (MonadProxy e w s r m) 45 | -> Proxy ki 46 | -> Proxy ty 47 | -> Proxy a 48 | -> Proxy i 49 | -> (Type ki ty a -> InferKindMonad m ki a i (Kind ki a)) 50 | -> Type ki ty a 51 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 52 | inferTyArr pm pki pty pa pi inferFn ty = do 53 | (ty1, ty2) <- preview _TyArr ty 54 | return $ do 55 | let kib = review _KiBase () 56 | mkCheckKind pm pki pty pa pi inferFn ty1 kib 57 | mkCheckKind pm pki pty pa pi inferFn ty2 kib 58 | return kib 59 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.TyArr.Rules.Kind.Infer.SyntaxDirected ( 10 | TyArrInferKindContext 11 | , tyArrInferKindRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | import Control.Monad.Except (MonadError) 16 | import Data.Functor.Classes (Eq1) 17 | 18 | import Ast.Kind 19 | import Ast.Type 20 | import Ast.Error.Common 21 | import Rules.Kind.Infer.SyntaxDirected 22 | 23 | import Fragment.KiBase.Ast.Kind 24 | import Fragment.TyArr.Ast.Type 25 | 26 | inferTyArr :: (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyArr ki ty) 27 | => (Type ki ty a -> m (Kind ki)) 28 | -> Type ki ty a 29 | -> Maybe (m (Kind ki)) 30 | inferTyArr inferFn ty = do 31 | (ty1, ty2) <- preview _TyArr ty 32 | return $ do 33 | let ki = review _KiBase() 34 | mkCheckKind inferFn ty1 ki 35 | mkCheckKind inferFn ty2 ki 36 | return . review _KiBase $ () 37 | 38 | type TyArrInferKindContext e w s r m ki ty a = (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyArr ki ty) 39 | 40 | tyArrInferKindRules :: TyArrInferKindContext e w s r m ki ty a 41 | => InferKindInput e w s r m ki ty a 42 | tyArrInferKindRules = 43 | InferKindInput 44 | [InferKindRecurse inferTyArr] 45 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.TyArr.Rules.Type ( 10 | TyArrNormalizeConstraint 11 | , tyArrNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.TyArr.Ast.Type 20 | 21 | type TyArrNormalizeConstraint ki ty a = AsTyArr ki ty 22 | 23 | normalizeArr :: TyArrNormalizeConstraint ki ty a 24 | => (Type ki ty a -> Type ki ty a) 25 | -> Type ki ty a 26 | -> Maybe (Type ki ty a) 27 | normalizeArr normalizeFn ty = do 28 | (ty1, ty2) <- preview _TyArr ty 29 | return $ review _TyArr (normalizeFn ty1, normalizeFn ty2) 30 | 31 | tyArrNormalizeRules :: TyArrNormalizeConstraint ki ty a 32 | => NormalizeInput ki ty a 33 | tyArrNormalizeRules = 34 | NormalizeInput [ NormalizeTypeRecurse normalizeArr ] 35 | -------------------------------------------------------------------------------- /src/Fragment/TyArr/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | module Fragment.TyArr.Rules.Type.Infer.Offline ( 12 | TyArrInferTypeContext 13 | , tyArrInferTypeRules 14 | ) where 15 | 16 | import Control.Lens (preview) 17 | import Data.Equivalence.Monad (EquivT, classDesc) 18 | 19 | import Ast.Type 20 | import Rules.Unification 21 | import Rules.Type.Infer.Offline 22 | 23 | import Fragment.TyArr.Ast.Type 24 | 25 | unifyArr :: (UnificationContext e m (Type ki ty) a, AsTyArr ki ty) 26 | => ([Type ki ty a] -> [Type ki ty a] -> EquivT s (Type ki ty a) (Type ki ty a) m ()) 27 | -> UConstraint (Type ki ty) a 28 | -> Maybe (EquivT s (Type ki ty a) (Type ki ty a) m ()) 29 | unifyArr unifyMany (UCEq ty1 ty2) = do 30 | (p1a, p1b) <- preview _TyArr ty1 31 | (p2a, p2b) <- preview _TyArr ty2 32 | return $ do 33 | c1a <- classDesc p1a 34 | c1b <- classDesc p1b 35 | c2a <- classDesc p2a 36 | c2b <- classDesc p2b 37 | unifyMany [c1a, c1b] [c2a, c2b] 38 | 39 | type TyArrInferTypeContext e w s r m ki ty (pt :: (* -> *) -> * -> *) (tm :: (* -> *) -> ((* -> *) -> (* -> *) -> * -> *) -> ((* -> *) -> * -> *) -> (* -> *) -> * -> *) a = (UnificationContext e m (Type ki ty) a, AsTyArr ki ty) 40 | 41 | tyArrInferTypeRules :: TyArrInferTypeContext e w s r m ki ty pt tm a 42 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 43 | tyArrInferTypeRules = 44 | InferTypeInput 45 | [UnificationMany unifyArr] 46 | [] 47 | [] 48 | -------------------------------------------------------------------------------- /src/Fragment/TyVar/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.TyVar.Helpers ( 9 | tyVar 10 | ) where 11 | 12 | import Control.Lens (review) 13 | 14 | import Ast.Type 15 | 16 | tyVar :: a -> Type ki ty a 17 | tyVar = review _TyVar 18 | -------------------------------------------------------------------------------- /src/Fragment/TyVar/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.TyVar.Rules ( 12 | RTyVar 13 | ) where 14 | 15 | import GHC.Exts (Constraint) 16 | 17 | import Ast 18 | import Rules 19 | 20 | import Fragment.TyVar.Rules.Kind.Infer.SyntaxDirected 21 | 22 | data RTyVar 23 | 24 | instance AstIn RTyVar where 25 | type KindList RTyVar = '[] 26 | type TypeList RTyVar = '[] 27 | type PatternList RTyVar = '[] 28 | type TermList RTyVar = '[] 29 | 30 | instance RulesIn RTyVar where 31 | type InferKindContextSyntax e w s r m ki ty a RTyVar = TyVarInferKindContext e w s r m ki ty a 32 | type InferTypeContextSyntax e w s r m ki ty pt tm a RTyVar = (() :: Constraint) 33 | type InferTypeContextOffline e w s r m ki ty pt tm a RTyVar = (() :: Constraint) 34 | type ErrorList ki ty tm pt a RTyVar = '[] 35 | type WarningList ki ty tm pt a RTyVar = '[] 36 | 37 | inferKindInputSyntax _ = tyVarInferKindRules 38 | inferTypeInputSyntax _ = mempty 39 | inferTypeInputOffline _ = mempty 40 | -------------------------------------------------------------------------------- /src/Fragment/TyVar/Rules/Kind/Infer/Common.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | module Fragment.TyVar.Rules.Kind.Infer.Common ( 14 | TyVarInferKindConstraint 15 | , tyVarInferKindInput 16 | ) where 17 | 18 | import Data.Proxy (Proxy(..)) 19 | 20 | import Control.Lens (preview) 21 | import Control.Monad.Except (MonadError) 22 | import Control.Monad.Reader (MonadReader) 23 | 24 | import Ast.Kind 25 | import Ast.Type 26 | import Rules.Kind.Infer.Common 27 | import Context.Type 28 | 29 | import Fragment.KiBase.Ast.Kind 30 | 31 | type TyVarInferKindConstraint e w s r m ki ty a i = 32 | ( BasicInferKindConstraint e w s r m ki ty a i 33 | , Ord a 34 | , AsKiBase ki 35 | , MonadReader r (InferKindMonad m ki a i) 36 | , HasTypeContext r ki a 37 | , MonadError e (InferKindMonad m ki a i) 38 | , AsUnboundTypeVariable e a 39 | ) 40 | 41 | tyVarInferKindInput :: TyVarInferKindConstraint e w s r m ki ty a i 42 | => Proxy (MonadProxy e w s r m) 43 | -> Proxy i 44 | -> InferKindInput e w s r m (InferKindMonad m ki a i) ki ty a 45 | tyVarInferKindInput m i = 46 | InferKindInput 47 | [] 48 | [ InferKindBase $ inferTyVar m (Proxy :: Proxy ki) (Proxy :: Proxy ty) (Proxy :: Proxy a) i ] 49 | 50 | inferTyVar :: TyVarInferKindConstraint e w s r m ki ty a i 51 | => Proxy (MonadProxy e w s r m) 52 | -> Proxy ki 53 | -> Proxy ty 54 | -> Proxy a 55 | -> Proxy i 56 | -> Type ki ty a 57 | -> Maybe (InferKindMonad m ki a i (Kind ki a)) 58 | inferTyVar _ _ _ _ _ ty = do 59 | v <- preview _TyVar ty 60 | return . lookupType $ v 61 | -------------------------------------------------------------------------------- /src/Fragment/TyVar/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Fragment.TyVar.Rules.Kind.Infer.SyntaxDirected ( 11 | TyVarInferKindContext 12 | , tyVarInferKindRules 13 | ) where 14 | 15 | import Control.Monad.Reader (MonadReader) 16 | import Control.Monad.Except (MonadError) 17 | import Control.Lens (preview) 18 | 19 | import Rules.Kind.Infer.SyntaxDirected 20 | import Ast.Kind 21 | import Ast.Type 22 | import Context.Type 23 | 24 | inferTyVar :: (Ord a, MonadReader r m, MonadError e m, HasTypeContext r ki a, AsUnboundTypeVariable e a) => Type ki ty a -> Maybe (m (Kind ki)) 25 | inferTyVar ty = do 26 | v <- preview _TyVar ty 27 | return $ lookupType v 28 | 29 | type TyVarInferKindContext e w s r m ki ty a = (InferKindContext e w s r m ki ty a, Ord a, MonadReader r m, HasTypeContext r ki a, MonadError e m, AsUnboundTypeVariable e a) 30 | 31 | tyVarInferKindRules :: TyVarInferKindContext e w s r m ki ty a 32 | => InferKindInput e w s r m ki ty a 33 | tyVarInferKindRules = 34 | InferKindInput 35 | [ InferKindBase inferTyVar ] 36 | -------------------------------------------------------------------------------- /src/Fragment/TyVar/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | module Fragment.TyVar.Rules.Type ( 11 | tyVarNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | normalizeTyVar :: Type ki ty a 20 | -> Maybe (Type ki ty a) 21 | normalizeTyVar ty = do 22 | _ <- preview _TyVar ty 23 | return ty 24 | 25 | tyVarNormalizeRules :: NormalizeInput ki ty a 26 | tyVarNormalizeRules = 27 | NormalizeInput [ NormalizeTypeBase normalizeTyVar ] 28 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Ast.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Variant.Ast ( 9 | module X 10 | ) where 11 | 12 | import Fragment.Variant.Ast.Type as X 13 | import Fragment.Variant.Ast.Error as X 14 | import Fragment.Variant.Ast.Pattern as X 15 | import Fragment.Variant.Ast.Term as X 16 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | module Fragment.Variant.Helpers ( 9 | tyVariant 10 | , ptVariant 11 | , tmVariant 12 | ) where 13 | 14 | import Control.Lens (review) 15 | 16 | import qualified Data.Text as T 17 | import qualified Data.List.NonEmpty as N 18 | 19 | import Ast.Type 20 | import Ast.Pattern 21 | import Ast.Term 22 | 23 | import Fragment.Variant.Ast.Type 24 | import Fragment.Variant.Ast.Pattern 25 | import Fragment.Variant.Ast.Term 26 | 27 | tyVariant :: AsTyVariant ki ty => N.NonEmpty (T.Text, Type ki ty a) -> Type ki ty a 28 | tyVariant = review _TyVariant 29 | 30 | ptVariant :: AsPtVariant pt => T.Text -> Pattern pt a -> Pattern pt a 31 | ptVariant = curry $ review _PtVariant 32 | 33 | tmVariant :: AsTmVariant ki ty pt tm => T.Text -> Term ki ty pt tm a -> Type ki ty a -> Term ki ty pt tm a 34 | tmVariant l tm ty = review _TmVariant (l, tm, ty) 35 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | module Fragment.Variant.Rules ( 12 | RVariant 13 | ) where 14 | 15 | import Ast 16 | import Rules 17 | 18 | import Fragment.KiBase.Ast.Kind 19 | 20 | import Fragment.Variant.Ast 21 | import qualified Fragment.Variant.Rules.Kind.Infer.SyntaxDirected as KSD 22 | import qualified Fragment.Variant.Rules.Type.Infer.SyntaxDirected as TSD 23 | import qualified Fragment.Variant.Rules.Type.Infer.Offline as TUO 24 | 25 | data RVariant 26 | 27 | instance AstIn RVariant where 28 | type KindList RVariant = '[KiFBase] 29 | type TypeList RVariant = '[TyFVariant] 30 | type PatternList RVariant = '[PtFVariant] 31 | type TermList RVariant = '[TmFVariant] 32 | 33 | instance RulesIn RVariant where 34 | type InferKindContextSyntax e w s r m ki ty a RVariant = KSD.VariantInferKindContext e w s r m ki ty a 35 | type InferTypeContextSyntax e w s r m ki ty pt tm a RVariant = TSD.VariantInferTypeContext e w s r m ki ty pt tm a 36 | type InferTypeContextOffline e w s r m ki ty pt tm a RVariant = TUO.VariantInferTypeContext e w s r m ki ty pt tm a 37 | type ErrorList ki ty pt tm a RVariant = '[ErrExpectedTyVariant ki ty a, ErrVariantNotFound] 38 | type WarningList ki ty pt tm a RVariant = '[] 39 | 40 | inferKindInputSyntax _ = KSD.variantInferKindRules 41 | inferTypeInputSyntax _ = TSD.variantInferTypeRules 42 | inferTypeInputOffline _ = TUO.variantInferTypeRules 43 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Variant.Rules.Kind.Infer.SyntaxDirected ( 10 | VariantInferKindContext 11 | , variantInferKindRules 12 | ) where 13 | 14 | import Data.Foldable (traverse_) 15 | 16 | import Control.Lens (review, preview) 17 | import Control.Monad.Except (MonadError) 18 | import Data.Functor.Classes (Eq1) 19 | 20 | import Ast.Kind 21 | import Ast.Type 22 | import Ast.Error.Common 23 | import Rules.Kind.Infer.SyntaxDirected 24 | 25 | import Fragment.KiBase.Ast.Kind 26 | import Fragment.Variant.Ast.Type 27 | 28 | inferTyVariant :: (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyVariant ki ty) 29 | => (Type ki ty a -> m (Kind ki)) 30 | -> Type ki ty a 31 | -> Maybe (m (Kind ki)) 32 | inferTyVariant inferFn ty = do 33 | tys <- preview _TyVariant ty 34 | return $ do 35 | let ki = review _KiBase() 36 | traverse_ (\(_, tyV) -> mkCheckKind inferFn tyV ki) tys 37 | return . review _KiBase $ () 38 | 39 | type VariantInferKindContext e w s r m ki ty a = (MonadError e m, AsUnexpectedKind e ki, Eq1 ki, AsKiBase ki, AsTyVariant ki ty) 40 | 41 | variantInferKindRules :: VariantInferKindContext e w s r m ki ty a 42 | => InferKindInput e w s r m ki ty a 43 | variantInferKindRules = 44 | InferKindInput 45 | [InferKindRecurse inferTyVariant] 46 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules/Term.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Variant.Rules.Term ( 10 | VariantEvalConstraint 11 | , variantEvalRules 12 | ) where 13 | 14 | import Control.Monad (MonadPlus(..)) 15 | 16 | import Control.Lens (review, preview) 17 | 18 | import Rules.Term 19 | import Ast.Pattern 20 | import Ast.Term 21 | 22 | import Fragment.Variant.Ast.Pattern 23 | import Fragment.Variant.Ast.Term 24 | 25 | valueVariant :: (AsTmVariant ki ty pt tm) => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 26 | valueVariant valueFn tm = do 27 | (l, tmV, ty) <- preview _TmVariant tm 28 | tm' <- valueFn tmV 29 | return $ review _TmVariant (l, tm', ty) 30 | 31 | stepVariant :: (AsTmVariant ki ty pt tm) => (Term ki ty pt tm a -> Maybe (Term ki ty pt tm a)) -> Term ki ty pt tm a -> Maybe (Term ki ty pt tm a) 32 | stepVariant stepFn tm = do 33 | (l, tmV, ty) <- preview _TmVariant tm 34 | tm' <- stepFn tmV 35 | return $ review _TmVariant (l, tm', ty) 36 | 37 | matchVariant :: (AsPtVariant pt, AsTmVariant ki ty pt tm) => (Pattern pt a -> Term ki ty pt tm a -> Maybe [Term ki ty pt tm a]) -> Pattern pt a -> Term ki ty pt tm a -> Maybe [Term ki ty pt tm a] 38 | matchVariant matchFn p tm = do 39 | (lP, pV) <- preview _PtVariant p 40 | (lV, tmV, _) <- preview _TmVariant tm 41 | if lP == lV 42 | then matchFn pV tmV 43 | else mzero 44 | 45 | type VariantEvalConstraint ki ty pt tm a = 46 | ( AsPtVariant pt 47 | , AsTmVariant ki ty pt tm 48 | ) 49 | 50 | variantEvalRules :: VariantEvalConstraint ki ty pt tm a 51 | => EvalInput ki ty pt tm a 52 | variantEvalRules = 53 | EvalInput 54 | [ ValueRecurse valueVariant ] 55 | [ StepRecurse stepVariant ] 56 | [ MatchRecurse matchVariant ] 57 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules/Type.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | module Fragment.Variant.Rules.Type ( 10 | VariantNormalizeConstraint 11 | , variantNormalizeRules 12 | ) where 13 | 14 | import Control.Lens (review, preview) 15 | 16 | import Rules.Type 17 | import Ast.Type 18 | 19 | import Fragment.Variant.Ast.Type 20 | 21 | type VariantNormalizeConstraint ki ty a = AsTyVariant ki ty 22 | 23 | normalizeVariant :: VariantNormalizeConstraint ki ty a 24 | => (Type ki ty a -> Type ki ty a) 25 | -> Type ki ty a 26 | -> Maybe (Type ki ty a) 27 | normalizeVariant normalizeFn ty = do 28 | tys <- preview _TyVariant ty 29 | return $ review _TyVariant (fmap (fmap normalizeFn) tys) 30 | 31 | variantNormalizeRules :: VariantNormalizeConstraint ki ty a 32 | => NormalizeInput ki ty a 33 | variantNormalizeRules = 34 | NormalizeInput [ NormalizeTypeRecurse normalizeVariant ] 35 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules/Type/Infer/Offline.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Variant.Rules.Type.Infer.Offline ( 11 | VariantInferTypeContext 12 | , variantInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.Offline 16 | 17 | import qualified Fragment.Variant.Rules.Type.Infer.Common as V 18 | 19 | type VariantInferTypeContext e w s r m ki ty pt tm a = 20 | V.VariantInferTypeContext e w s r m (UnifyT ki ty a m) ki ty pt tm a 21 | 22 | variantInferTypeRules :: VariantInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m (UnifyT ki ty a m) ki ty pt tm a 24 | variantInferTypeRules = 25 | let 26 | vh = V.VariantHelper expectTypeEq 27 | in 28 | V.inferTypeInput vh 29 | -------------------------------------------------------------------------------- /src/Fragment/Variant/Rules/Type/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE ConstraintKinds #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | module Fragment.Variant.Rules.Type.Infer.SyntaxDirected ( 11 | VariantInferTypeContext 12 | , variantInferTypeRules 13 | ) where 14 | 15 | import Rules.Type.Infer.SyntaxDirected 16 | 17 | import qualified Fragment.Variant.Rules.Type.Infer.Common as V 18 | 19 | type VariantInferTypeContext e w s r m ki ty pt tm a = 20 | V.VariantInferTypeContext e w s r m m ki ty pt tm a 21 | 22 | variantInferTypeRules :: VariantInferTypeContext e w s r m ki ty pt tm a 23 | => InferTypeInput e w s r m m ki ty pt tm a 24 | variantInferTypeRules = 25 | let 26 | vh = V.VariantHelper expectTypeEq 27 | in 28 | V.inferTypeInput vh 29 | -------------------------------------------------------------------------------- /src/Rules/Kind/Infer/SyntaxDirected.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE FlexibleContexts #-} 11 | {-# LANGUAGE DataKinds #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE ScopedTypeVariables #-} 14 | module Rules.Kind.Infer.SyntaxDirected ( 15 | IKSyntax 16 | ) where 17 | 18 | import Control.Monad (unless) 19 | 20 | import Control.Monad.Except (MonadError) 21 | import Control.Monad.Error.Lens (throwing) 22 | 23 | import Data.List.NonEmpty (NonEmpty(..)) 24 | 25 | import Ast.Error.Common 26 | import Data.Functor.Rec 27 | 28 | import Rules.Kind.Infer.Common 29 | 30 | data IKSyntax 31 | 32 | instance MkInferKind IKSyntax where 33 | type MkInferKindConstraint e w s r m ki ty a IKSyntax = 34 | ( Eq a 35 | , EqRec ki 36 | , MonadError e m 37 | , AsUnknownKindError e 38 | , AsUnexpectedKind e ki a 39 | , AsExpectedKindEq e ki a 40 | , AsExpectedKindAllEq e ki a 41 | ) 42 | type InferKindMonad m ki a IKSyntax = 43 | m 44 | type MkInferKindErrorList ki ty a IKSyntax = 45 | '[] 46 | type MkInferKindWarningList ki ty a IKSyntax = 47 | '[] 48 | 49 | mkCheckKind m ki ty a i = 50 | mkCheckKind' i (expectKind m ki ty a i) 51 | 52 | expectKind _ _ _ _ _ e@(ExpectedKind ki1) a@(ActualKind ki2) = 53 | unless (ki1 == ki2) $ 54 | throwing _UnexpectedKind (e, a) 55 | 56 | expectKindEq _ _ _ _ _ ki1 ki2 = 57 | unless (ki1 == ki2) $ 58 | throwing _ExpectedKindEq (ki1, ki2) 59 | 60 | expectKindAllEq _ _ _ _ _ (ki :| kis) = do 61 | unless (all (== ki) kis) $ 62 | throwing _ExpectedKindAllEq (ki :| kis) 63 | return ki 64 | 65 | prepareInferKind pm pki pty pa pi ki = 66 | let 67 | i = mkInferKind . kriInferRules $ ki 68 | c = mkCheckKind pm pki pty pa pi i 69 | in 70 | InferKindOutput i c 71 | -------------------------------------------------------------------------------- /src/Util/MonadProxy.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE KindSignatures #-} 9 | module Util.MonadProxy ( 10 | MonadProxy 11 | ) where 12 | 13 | data MonadProxy (e :: *) (w :: *) (s :: *) (r :: *) (m :: * -> *) 14 | -------------------------------------------------------------------------------- /src/Util/NonEmpty.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE DeriveFunctor #-} 9 | {-# LANGUAGE DeriveFoldable #-} 10 | {-# LANGUAGE DeriveTraversable #-} 11 | {-# LANGUAGE TemplateHaskell #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | {-# LANGUAGE TypeFamilies #-} 15 | module Util.NonEmpty ( 16 | NE(..) 17 | ) where 18 | 19 | import Control.Lens.TH (makeWrapped) 20 | import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..)) 21 | import Data.List.NonEmpty (NonEmpty) 22 | import Data.Deriving (makeLiftEq, makeLiftCompare, makeLiftShowsPrec) 23 | 24 | newtype NE a = NE { unNE :: NonEmpty a } 25 | deriving (Eq, Ord, Show, Functor, Foldable, Traversable) 26 | 27 | makeWrapped ''NE 28 | 29 | instance Eq1 NE where 30 | liftEq e (NE x) (NE y) = $(makeLiftEq ''NonEmpty) e x y 31 | 32 | instance Ord1 NE where 33 | liftCompare c (NE x) (NE y) = $(makeLiftCompare ''NonEmpty) c x y 34 | 35 | instance Show1 NE where 36 | liftShowsPrec s sl n (NE x) = $(makeLiftShowsPrec ''NonEmpty) s sl n x 37 | -------------------------------------------------------------------------------- /src/Util/Prisms.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE RankNTypes #-} 9 | module Util.Prisms ( 10 | mkPair 11 | , mkTriple 12 | , capFst 13 | ) where 14 | 15 | import Control.Lens 16 | 17 | mkPair :: Prism' a b -> Prism' c d -> Prism' (a,c) (b, d) 18 | mkPair p1 p2 = prism f g 19 | where 20 | f (x, y) = (review p1 x, review p2 y) 21 | g (x, y) = case (,) <$> preview p1 x <*> preview p2 y of 22 | Just z -> Right z 23 | Nothing -> Left (x, y) 24 | 25 | mkTriple :: Prism' a b -> Prism' c d -> Prism' e f -> Prism' (a, c, e) (b, d, f) 26 | mkTriple p1 p2 p3 = prism f g 27 | where 28 | f (x, y, z) = (review p1 x, review p2 y, review p3 z) 29 | g (x, y, z) = case (\a b c -> (a, b, c)) <$> preview p1 x <*> preview p2 y <*> preview p3 z of 30 | Just a -> Right a 31 | Nothing -> Left (x, y, z) 32 | 33 | capFst :: Iso' ((), b) b 34 | capFst = iso 35 | (\((), x) -> x) 36 | (\x -> ((), x)) 37 | -------------------------------------------------------------------------------- /src/Util/TypeList.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Copyright : (c) Dave Laing, 2017 3 | License : BSD3 4 | Maintainer : dave.laing.80@gmail.com 5 | Stability : experimental 6 | Portability : non-portable 7 | -} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE DataKinds #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE MultiParamTypeClasses #-} 13 | {-# LANGUAGE FlexibleInstances #-} 14 | module Util.TypeList ( 15 | TLAppend(..) 16 | ) where 17 | 18 | class TLAppend (xs :: [k]) (ys :: [k]) where 19 | type Append xs ys :: [k] 20 | 21 | instance TLAppend '[] ys where 22 | type Append '[] ys = ys 23 | 24 | instance TLAppend xs ys => TLAppend (x ': xs) ys where 25 | type Append (x ': xs) ys = x ': (Append xs ys) 26 | --------------------------------------------------------------------------------