├── .gitignore ├── LICENSE ├── Setup.hs ├── cabal.project ├── dang.cabal ├── dang └── Main.hs ├── examples ├── Set.dg └── simple.dg └── src ├── Dang.hs └── Dang ├── AST.hs ├── Core └── AST.hs ├── Message.hs ├── ModuleSystem ├── Env.hs ├── Name.hs └── Rename.hs ├── Monad.hs ├── Syntax ├── .gitignore ├── AST.hs ├── Format.hs ├── Lexer.x ├── Location.hs ├── Parser.y └── Signatures.hs ├── TypeCheck ├── AST.hs ├── Env.hs ├── KindCheck.hs ├── Monad.hs └── Subst.hs ├── Unique.hs └── Utils ├── Ident.hs ├── PP.hs └── Panic.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .cabal-sandbox/ 4 | cabal.sandbox.config 5 | cabal.project.local 6 | .ghc.environment.* 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Trevor Elliott 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 Trevor Elliott 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 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /dang.cabal: -------------------------------------------------------------------------------- 1 | name: dang 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Trevor Elliott 6 | maintainer: awesomelyawesome@gmail.com 7 | copyright: 2015 8 | category: Language 9 | build-type: Simple 10 | cabal-version: >= 1.10 11 | 12 | library 13 | hs-source-dirs: src 14 | default-language: Haskell2010 15 | exposed-modules: Dang 16 | Dang.AST 17 | Dang.Message 18 | Dang.ModuleSystem.Env 19 | Dang.ModuleSystem.Name 20 | Dang.ModuleSystem.Rename 21 | Dang.Monad 22 | Dang.Syntax.AST 23 | Dang.Syntax.Format 24 | Dang.Syntax.Lexer 25 | Dang.Syntax.Location 26 | Dang.Syntax.Parser 27 | Dang.Syntax.Signatures 28 | Dang.TypeCheck.AST 29 | Dang.TypeCheck.KindCheck 30 | Dang.TypeCheck.Monad 31 | Dang.TypeCheck.Subst 32 | Dang.Unique 33 | Dang.Utils.Ident 34 | Dang.Utils.Panic 35 | Dang.Utils.PP 36 | build-depends: base >= 4.8 && <5, 37 | array, 38 | ansi-terminal, 39 | monadLib, 40 | pretty >= 1.1.3.2, 41 | containers, 42 | lens, 43 | text, 44 | terminal-size, 45 | alex-tools >= 0.3, 46 | layout-rules 47 | ghc-options: -Wall 48 | 49 | executable dang 50 | main-is: Main.hs 51 | default-language: Haskell2010 52 | build-depends: base >=4.8 && <5, 53 | containers, 54 | text, 55 | pretty-show, 56 | dang 57 | hs-source-dirs: dang 58 | default-language: Haskell2010 59 | ghc-options: -Wall 60 | -------------------------------------------------------------------------------- /dang/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Main where 4 | 5 | import Dang.ModuleSystem.Rename 6 | import Dang.Monad 7 | import Dang.Syntax.Format (formatMessage) 8 | import Dang.Syntax.Lexer 9 | import Dang.Syntax.Location 10 | (SourceRange(..),SourcePos(..),HasRange(..),interactive) 11 | import Dang.Syntax.Parser 12 | import Dang.Syntax.Signatures 13 | import qualified Dang.TypeCheck.KindCheck as KC 14 | import Dang.Utils.PP 15 | 16 | import qualified Data.Foldable as F 17 | import Data.List (sortBy) 18 | import Data.Ord (comparing) 19 | import qualified Data.Text as S 20 | import qualified Data.Text.IO as S 21 | import System.Exit (exitFailure) 22 | import System.Environment (getArgs) 23 | import Text.Show.Pretty (pPrint) 24 | 25 | 26 | main :: IO () 27 | main = runDang $ 28 | do args <- io getArgs 29 | file <- case args of 30 | [file] -> return file 31 | _ -> io $ do putStrLn "Usage: dang file.dg" 32 | exitFailure 33 | 34 | txt <- io (S.readFile file) 35 | io (mapM_ (print . lexemeToken) (lexWithLayout (S.pack file) Nothing txt)) 36 | 37 | let dumpMessages ms = 38 | io $ printDoc defaultConfig 39 | $ vcat 40 | $ map (formatMessage (S.pack file) txt) 41 | $ sortBy (comparing (sourceIndex . sourceFrom . range)) 42 | $ F.toList ms 43 | 44 | (mbMod,ms) <- collectMessages $ try $ 45 | do pMod <- parseModule (S.pack file) txt 46 | sMod <- resolveSignatures pMod 47 | rnMod <- renameModule sMod 48 | -- KC.checkModule rnMod 49 | return rnMod 50 | 51 | io (pPrint mbMod) 52 | 53 | if null ms 54 | then io (putStrLn "No messages") 55 | else dumpMessages ms 56 | -------------------------------------------------------------------------------- /examples/Set.dg: -------------------------------------------------------------------------------- 1 | 2 | module Set where 3 | 4 | data Bool = True | False 5 | 6 | not : Bool -> Bool 7 | not b = 8 | case b of 9 | True -> False 10 | False -> True 11 | 12 | 13 | module type Ord = sig 14 | 15 | -- a concrete type 16 | data Ordering = LT | EQ | GT 17 | 18 | -- a kind signature 19 | type T : Type 20 | -- a value signature 21 | compare : T -> T -> Ordering 22 | 23 | 24 | module Eq (Cmp : Ord) = struct 25 | 26 | eq, neq : Cmp.T -> Cmp.T -> Bool 27 | 28 | eq a b = 29 | case Cmp.compare a b of 30 | Cmp.EQ -> True 31 | _ -> False 32 | 33 | neq a b = not (eq a b) 34 | 35 | 36 | module Make (Cmp : Ord) = struct 37 | 38 | -- simple function-as-set 39 | type Set = Cmp.T -> Bool 40 | 41 | insert, delete : Cmp.T -> Set -> Set 42 | 43 | insert x s = \ x' -> 44 | case Cmp.compare x x' of 45 | Cmp.EQ -> True 46 | _ -> s x' 47 | 48 | delete x s = \ x' -> 49 | case Cmp.compare x x' of 50 | Cmp.EQ -> False 51 | _ -> s x' 52 | 53 | member : Cmp.T -> Set -> Bool 54 | member x s = s x 55 | -------------------------------------------------------------------------------- /examples/simple.dg: -------------------------------------------------------------------------------- 1 | module Simple where 2 | 3 | f : a -> a 4 | f x = x 5 | 6 | data Ord = LT | EQ | GT 7 | -------------------------------------------------------------------------------- /src/Dang.hs: -------------------------------------------------------------------------------- 1 | module Dang where 2 | -------------------------------------------------------------------------------- /src/Dang/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | 6 | module Dang.AST ( 7 | module Dang.AST, 8 | Constraint 9 | ) where 10 | 11 | import GHC.Exts (Constraint) 12 | 13 | 14 | -- | The type of identifiers. 15 | type family IdentOf syn :: * 16 | 17 | -- | The type of types. 18 | type family TypeOf syn :: * 19 | 20 | -- | The type of type schemas. 21 | type family SchemaOf syn :: * 22 | 23 | -- | The type of metadata. 24 | type family MetaOf syn :: * 25 | 26 | 27 | type Cxt (f :: * -> Constraint) syn = 28 | ( f (IdentOf syn) 29 | , f (TypeOf syn) 30 | , f (SchemaOf syn) 31 | , f (MetaOf syn) 32 | ) 33 | -------------------------------------------------------------------------------- /src/Dang/Core/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module Dang.Core.AST where 4 | 5 | import Dang.Utils.PP 6 | 7 | import Data.Function (on) 8 | import GHC.Generics (Generic) 9 | 10 | 11 | data Schema a = Schema [TParam] a 12 | deriving (Show,Generic) 13 | 14 | type Kind = Type 15 | 16 | data Type = TApp Type Type 17 | | TCon TyCon 18 | | TFree TParam 19 | | TGen TParam 20 | deriving (Eq,Show,Generic) 21 | 22 | data TyCon = TyCon { tcName :: String 23 | , tcInfix :: Bool 24 | , tcKind :: Kind 25 | } deriving (Show,Generic) 26 | 27 | data TParam = TParam { tpName :: String 28 | , tpIndex :: !Int 29 | , tpKind :: Kind 30 | } deriving (Show,Generic) 31 | 32 | data Expr = EApp Expr [Expr] 33 | | EAbs 34 | 35 | 36 | -- Type Constants -------------------------------------------------------------- 37 | 38 | tcArrow :: TyCon 39 | tcArrow = TyCon { tcName = "->", tcInfix = True, tcKind = kSet } 40 | 41 | tArrow :: Type -> Type -> Type 42 | tArrow l r = TCon tcArrow `TApp` l `TApp` r 43 | 44 | 45 | -- Kind Constants -------------------------------------------------------------- 46 | 47 | kSet :: Kind 48 | kSet = TCon TyCon { tcName = "Set", tcInfix = False, tcKind = kSet } 49 | 50 | kArrow :: Kind -> Kind -> Kind 51 | kArrow l r = TCon tcArrow `TApp` l `TApp` r 52 | 53 | 54 | -- Utilities ------------------------------------------------------------------- 55 | 56 | instance Eq TyCon where 57 | (==) = (==) `on` tcName 58 | 59 | instance Eq TParam where 60 | (==) = (==) `on` tpIndex 61 | (/=) = (/=) `on` tpIndex 62 | 63 | instance Ord TParam where 64 | compare = compare `on` tpIndex 65 | 66 | mapTGen :: (TParam -> TParam) -> Type -> Type 67 | mapTGen f = go 68 | where 69 | go (TApp l r) = TApp (go l) (go r) 70 | go (TGen p) = TGen (f p) 71 | go ty@TFree{} = ty 72 | go ty@TCon{} = ty 73 | -------------------------------------------------------------------------------- /src/Dang/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Dang.Message where 5 | 6 | import Dang.Syntax.Location 7 | import Dang.Utils.PP 8 | 9 | 10 | data Error = ErrLexer 11 | | ErrParser 12 | | ErrDuplicateSig 13 | | ErrNoDeclForSig 14 | | ErrRnOverlap 15 | | ErrRnUnknown 16 | | ErrUnification 17 | | ErrInfiniteType 18 | deriving (Show,Eq,Ord) 19 | 20 | describeError :: Error -> Doc 21 | describeError ErrLexer = text "Lexcial error" 22 | describeError ErrParser = text "Parse error" 23 | describeError ErrDuplicateSig = text "Duplicate type signature for declaration" 24 | 25 | describeError ErrNoDeclForSig = flow 26 | "The type signature is missing a declaration. If the value binding exists, \ 27 | \ moving the signature above it in the file should fix the problem." 28 | 29 | describeError ErrRnOverlap = text "Names overlap" 30 | describeError ErrRnUnknown = text "Name not in scope" 31 | describeError ErrUnification = text "Unification failed" 32 | describeError ErrInfiniteType = text "Occurs check failed" 33 | 34 | data Warning = WarnRnShadowing 35 | deriving (Show,Eq,Ord) 36 | 37 | describeWarning :: Warning -> Doc 38 | describeWarning WarnRnShadowing = text "Name shadowing" 39 | 40 | data MessageType = Error Error 41 | | Warning Warning 42 | deriving (Show,Eq,Ord) 43 | 44 | describeMessageType :: MessageType -> Doc 45 | describeMessageType (Error err) = describeError err 46 | describeMessageType (Warning warn) = describeWarning warn 47 | 48 | data Message = Message { msgType :: !MessageType 49 | , msgSource :: !SourceRange 50 | , msgDoc :: Doc 51 | } deriving (Show) 52 | 53 | instance HasRange Message where 54 | range = msgSource 55 | {-# INLINE range #-} 56 | 57 | 58 | mkError :: Error -> SourceRange -> Doc -> Message 59 | mkError err msgSource msgDoc = Message { msgType = Error err, .. } 60 | {-# INLINE mkError #-} 61 | 62 | isError :: Message -> Bool 63 | isError Message { msgType = Error{} } = True 64 | isError _ = False 65 | 66 | mkWarning :: Warning -> SourceRange -> Doc -> Message 67 | mkWarning warn msgSource msgDoc = Message { msgType = Warning warn, .. } 68 | {-# INLINE mkWarning #-} 69 | 70 | isWarning :: Message -> Bool 71 | isWarning Message { msgType = Warning{} } = True 72 | isWarning _ = False 73 | -------------------------------------------------------------------------------- /src/Dang/ModuleSystem/Env.hs: -------------------------------------------------------------------------------- 1 | module Dang.ModuleSystem.Env ( 2 | NameTrie(), 3 | NameNode(..), 4 | Def(..), 5 | envVal, envType, envMod, 6 | qualify, 7 | insertPName, 8 | lookupVal, 9 | lookupType, 10 | lookupMod, 11 | lookupPName, 12 | openMod, 13 | shadowing, 14 | intersectionWith, 15 | ) where 16 | 17 | import Dang.Syntax.AST (PName(..)) 18 | import Dang.Utils.PP 19 | import Dang.Utils.Panic (panic) 20 | 21 | import Control.Monad (mplus) 22 | import qualified Data.Map.Strict as Map 23 | import qualified Data.Text as T 24 | 25 | 26 | -- Naming Environment ---------------------------------------------------------- 27 | 28 | data Def = DefMod !T.Text 29 | | DefVal !T.Text 30 | | DefType !T.Text 31 | deriving (Eq,Ord,Show) 32 | 33 | instance PP Def where 34 | ppr (DefMod n) = ppr n 35 | ppr (DefVal n) = ppr n 36 | ppr (DefType n) = ppr n 37 | 38 | 39 | newtype NameTrie a = NameTrie (Map.Map Def (NameNode a)) 40 | deriving (Show) 41 | 42 | data NameNode a = NameNode (Maybe a) (NameTrie a) 43 | deriving (Show) 44 | 45 | instance Monoid a => Monoid (NameTrie a) where 46 | mempty = NameTrie Map.empty 47 | mappend (NameTrie a) (NameTrie b) = NameTrie (Map.unionWith merge a b) 48 | where 49 | merge (NameNode xs x) (NameNode ys y) = 50 | NameNode (mappend xs ys) (mappend x y) 51 | 52 | {-# INLINE mempty #-} 53 | {-# INLINE mappend #-} 54 | 55 | -- | Merge the names from the left environment, into the right environment, 56 | -- allowing shadowing of names in the right environment. 57 | shadowing :: NameTrie a -> NameTrie a -> NameTrie a 58 | shadowing (NameTrie l) (NameTrie r) = NameTrie (Map.unionWith merge l r) 59 | where 60 | merge (NameNode a l') (NameNode b r') = NameNode (a `mplus` b) (shadowing l' r') 61 | 62 | qualify :: [T.Text] -> NameTrie a -> NameTrie a 63 | qualify ns t = foldr step t ns 64 | where 65 | step n acc = NameTrie (Map.singleton (DefMod n) (NameNode Nothing acc)) 66 | 67 | envVal, envType, envMod :: Monoid a => PName -> a -> NameTrie a 68 | envVal = singleton DefVal 69 | envType = singleton DefType 70 | envMod = singleton DefMod 71 | 72 | singleton :: Monoid a => (T.Text -> Def) -> PName -> a -> NameTrie a 73 | singleton mkDef pn n = 74 | case pn of 75 | PQual _ ns p -> qualify ns (mk p) 76 | PUnqual _ p -> mk p 77 | where 78 | mk p = NameTrie (Map.singleton (mkDef p) (NameNode (Just n) mempty)) 79 | 80 | 81 | insertPName :: Monoid a => (T.Text -> Def) -> PName -> a -> NameTrie a -> NameTrie a 82 | insertPName mkDef pn a = 83 | case pn of 84 | PUnqual _ p -> go (mkDef p) [] 85 | PQual _ ns p -> 86 | case map DefMod ns ++ [mkDef p] of 87 | n:ns' -> go n ns' 88 | _ -> panic (text "Invalid qualified name") 89 | 90 | 91 | where 92 | go n ns (NameTrie m) = NameTrie (Map.alter upd n m) 93 | where 94 | upd mb = 95 | case ns of 96 | n':rest -> 97 | case mb of 98 | Just (NameNode x sub) -> Just (NameNode x (go n' rest sub)) 99 | Nothing -> Just (NameNode Nothing (go n' rest mempty)) 100 | 101 | [] -> 102 | case mb of 103 | Just (NameNode x sub) -> Just (NameNode (Just a `mappend` x) sub) 104 | Nothing -> Just (NameNode (Just a) mempty) 105 | 106 | 107 | lookupVal, lookupType, lookupMod :: PName -> NameTrie a -> Maybe a 108 | 109 | lookupVal pn t = 110 | case lookupPName DefVal pn t of 111 | Just (NameNode mb _) -> mb 112 | Nothing -> Nothing 113 | 114 | lookupType pn t = 115 | case lookupPName DefType pn t of 116 | Just (NameNode mb _) -> mb 117 | Nothing -> Nothing 118 | 119 | lookupMod pn t = 120 | case lookupPName DefMod pn t of 121 | Just (NameNode mb _) -> mb 122 | Nothing -> Nothing 123 | 124 | lookupPName :: (T.Text -> Def) -> PName -> NameTrie a -> Maybe (NameNode a) 125 | lookupPName mkDef pn = 126 | case pn of 127 | PQual _ ns p -> go (map DefMod ns ++ [mkDef p]) 128 | PUnqual _ p -> go [mkDef p] 129 | 130 | where 131 | go (n:ns) (NameTrie m) = 132 | do t@(NameNode _ m') <- Map.lookup n m 133 | if null ns 134 | then return t 135 | else go ns m' 136 | 137 | go [] _ = error "Impossible" 138 | 139 | -- | Open the module with the name N in the environment E. 140 | openMod :: PName -> NameTrie a -> NameTrie a 141 | openMod pn e = 142 | case lookupPName DefMod pn e of 143 | Just (NameNode _ ds) -> ds `shadowing` e 144 | Nothing -> e 145 | 146 | 147 | intersectionWith :: (Maybe a -> Maybe b -> Maybe c) 148 | -> NameTrie a -> NameTrie b -> NameTrie c 149 | intersectionWith f = go 150 | where 151 | go (NameTrie l) (NameTrie r) = 152 | NameTrie (Map.intersectionWith merge l r) 153 | 154 | merge (NameNode xs l') (NameNode ys r') = 155 | NameNode (f xs ys) (go l' r') 156 | -------------------------------------------------------------------------------- /src/Dang/ModuleSystem/Name.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Dang.ModuleSystem.Name ( 5 | ModInfo(..), 6 | ParamSource(..), 7 | NameSort(..), 8 | Name(), 9 | nameSort, 10 | nameIdent, 11 | nameUnique, 12 | 13 | mkModName, 14 | mkBinding, 15 | mkParam, 16 | mkUnknown, 17 | 18 | ppNameOrigin, 19 | ) where 20 | 21 | import Dang.Syntax.AST (PName(..)) 22 | import Dang.Syntax.Location (HasRange(..),SourceRange) 23 | import Dang.Unique 24 | import Dang.Utils.Ident 25 | import Dang.Utils.PP 26 | 27 | import Data.Function (on) 28 | import qualified Data.Text as T 29 | 30 | 31 | data ModInfo = ModInfo { modName :: !Namespace 32 | } deriving (Eq,Show) 33 | 34 | data ParamSource = FromMod !Name 35 | | FromBind !Name 36 | | FromType !Name 37 | | FromFunctor !SourceRange 38 | | FromLambda !SourceRange 39 | | FromCase !SourceRange 40 | deriving (Eq,Show) 41 | 42 | -- | Information about where a name comes from, like in GHC. 43 | data NameSort = Declaration !ModInfo 44 | -- ^ Externally visible, comes from this module 45 | 46 | | Parameter !ParamSource 47 | -- ^ Type/function parameter to this declaration. 48 | 49 | | ModDecl !(Maybe ModInfo) 50 | -- ^ A module, declared in this module. 51 | deriving (Eq,Show) 52 | 53 | data Name = Name { nUnique :: {-# UNPACK #-} !(Unique Name) 54 | -- ^ The unique number assigned to this name for this run of 55 | -- the compiler. 56 | 57 | , nSort :: !NameSort 58 | -- ^ What kind of name this is. 59 | 60 | , nName :: {-# UNPACK #-} !Ident 61 | -- ^ The actual name. 62 | 63 | , nFrom :: !SourceRange 64 | -- ^ Where this name is defined. 65 | } deriving (Show) 66 | 67 | instance Eq Name where 68 | (==) = (==) `on` nUnique 69 | (/=) = (/=) `on` nUnique 70 | {-# INLINE (==) #-} 71 | {-# INLINE (/=) #-} 72 | 73 | instance Ord Name where 74 | compare = compare `on` nUnique 75 | {-# INLINE compare #-} 76 | 77 | instance HasRange Name where 78 | range Name { .. } = nFrom 79 | {-# INLINE range #-} 80 | 81 | -- | Retrieve the text associated with the 'Name'. 82 | nameIdent :: Name -> Ident 83 | nameIdent Name { .. } = nName 84 | 85 | -- | Information about what kind of 'Name' this is. 86 | nameSort :: Name -> NameSort 87 | nameSort Name { .. } = nSort 88 | 89 | -- | Retrieve the unique associated with this name. 90 | nameUnique :: Name -> Unique Name 91 | nameUnique Name { .. } = nUnique 92 | 93 | 94 | -- Name Construction ----------------------------------------------------------- 95 | 96 | mkModName :: Maybe Namespace -> T.Text -> SourceRange -> Supply -> (Supply,Name) 97 | mkModName mbNs n nFrom s = 98 | let (s',nUnique) = nextUnique s 99 | name = Name { nSort = ModDecl (ModInfo `fmap` mbNs) 100 | , nName = mkIdent n 101 | , .. } 102 | in (s',name) 103 | 104 | -- | Generate a name for a binding site. 105 | mkBinding :: Namespace -> T.Text -> SourceRange -> Supply -> (Supply,Name) 106 | mkBinding ns n nFrom s = 107 | let (s',nUnique) = nextUnique s 108 | name = Name { nSort = Declaration (ModInfo ns) 109 | , nName = mkIdent n 110 | , .. } 111 | in (s',name) 112 | 113 | 114 | mkParam :: ParamSource -> T.Text -> SourceRange -> Supply -> (Supply,Name) 115 | mkParam d n nFrom s = 116 | let (s',nUnique) = nextUnique s 117 | name = Name { nSort = Parameter d 118 | , nName = mkIdent n 119 | , .. } 120 | in (s',name) 121 | 122 | 123 | -- | Generate a bogus name from a parsed name. This is useful during renaming 124 | -- when we need to generate a name to finish the pass, but have already 125 | -- generated errors, invalidating the output. 126 | mkUnknown :: NameSort -> PName -> SourceRange -> Supply -> (Supply,Name) 127 | 128 | mkUnknown nSort (PUnqual _ n) src s = 129 | let (s',nUnique) = nextUnique s 130 | name = Name { nName = mkIdent n 131 | , nFrom = src 132 | , .. } 133 | in name `seq` s' `seq` (s',name) 134 | 135 | mkUnknown nSort (PQual _ _ n) src s = 136 | let (s',nUnique) = nextUnique s 137 | name = Name { nName = mkIdent n 138 | , nFrom = src 139 | , .. } 140 | in name `seq` s' `seq` (s',name) 141 | {-# INLINE mkUnknown #-} 142 | 143 | 144 | -- Pretty-printing ------------------------------------------------------------- 145 | 146 | ppNameOrigin :: Name -> Doc 147 | ppNameOrigin Name { .. } = 148 | case nSort of 149 | Declaration (ModInfo ns) -> 150 | text "from module" <+> quotes (pp ns) <+> text "at" <+> pp nFrom 151 | 152 | Parameter (FromMod m) -> 153 | text "module parameter to" <+> quotes (pp m) <+> text "at" <+> pp nFrom 154 | 155 | Parameter (FromBind fn) -> 156 | text "parameter to" <+> quotes (pp fn) <+> text "at" <+> pp nFrom 157 | 158 | Parameter (FromType sig) -> 159 | text "type parameter to" <+> quotes (pp sig) <+> text "at" <+> pp nFrom 160 | 161 | Parameter FromFunctor{} -> 162 | text "parameter to functor at" <+> pp nFrom 163 | 164 | Parameter FromLambda{} -> 165 | text "parameter to lambda abstraction at" <+> pp nFrom 166 | 167 | Parameter FromCase{} -> 168 | text "bound in case arm at" <+> pp nFrom 169 | 170 | ModDecl (Just (ModInfo ns)) -> 171 | text "from module" <+> quotes (pp ns) <+> text "at" <+> pp nFrom 172 | 173 | ModDecl Nothing -> 174 | text "at" <+> pp nFrom 175 | 176 | instance PP Name where 177 | ppr Name { .. } = 178 | case nSort of 179 | 180 | Declaration (ModInfo ns) -> 181 | do mb <- getNameFormat ns nName 182 | case mb of 183 | Just (Qualified ns') -> pp ns' <> char '.' <> pp nName 184 | Just UnQualified -> pp nName 185 | Nothing -> pp ns <> char '.' <> pp nName 186 | 187 | ModDecl (Just (ModInfo ns)) -> 188 | do mb <- getNameFormat ns nName 189 | case mb of 190 | Just (Qualified ns') -> pp ns' <> char '.' <> pp nName 191 | Just UnQualified -> pp nName 192 | Nothing -> pp ns <> char '.' <> pp nName 193 | 194 | ModDecl Nothing -> 195 | pp nName 196 | 197 | Parameter _ -> 198 | pp nName 199 | -------------------------------------------------------------------------------- /src/Dang/ModuleSystem/Rename.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE Rank2Types #-} 6 | 7 | module Dang.ModuleSystem.Rename ( 8 | Renamed, 9 | renameModule, 10 | ) where 11 | 12 | import Dang.AST 13 | import Dang.Monad 14 | import Dang.Syntax.AST 15 | import Dang.Syntax.Location 16 | import Dang.ModuleSystem.Env 17 | import Dang.ModuleSystem.Name hiding (modName) 18 | import Dang.Unique (withSupply) 19 | import Dang.Utils.Ident (Namespace,packNamespace,dot) 20 | import Dang.Utils.PP 21 | import Dang.Utils.Panic 22 | 23 | import Control.Applicative (Alternative(..)) 24 | import Control.Monad (MonadPlus) 25 | import Control.Lens (Lens',over,view) 26 | import qualified Data.Text as T 27 | import Data.Maybe (fromMaybe) 28 | import MonadLib (runM,BaseM(..),StateT,get,sets,sets_) 29 | 30 | 31 | data Renamed 32 | 33 | type instance IdentOf Renamed = Name 34 | type instance TypeOf Renamed = Type Renamed 35 | type instance SchemaOf Renamed = Schema Renamed 36 | type instance MetaOf Renamed = SourceRange 37 | 38 | 39 | -- | Rename a top-level module. 40 | renameModule :: HasCallStack => Module Parsed -> Dang (Module Renamed) 41 | renameModule m = 42 | rename (pnameNamespace (modName m)) (rnTopModule m) 43 | 44 | 45 | -- Renaming Monad -------------------------------------------------------------- 46 | 47 | type Names = NameTrie [Name] 48 | 49 | data Scope = Scope { scopeNS :: !Namespace -- ^ Fully-qualified namespace 50 | , scopePrefix :: [T.Text] -- ^ Relative prefix 51 | , scopePublic :: Names 52 | , scopePrivate :: Names 53 | } deriving (Show) 54 | 55 | newtype Visibility = V { unV :: Lens' Scope Names } 56 | 57 | publicVisibility, privateVisibility :: Visibility 58 | 59 | publicVisibility = V $ \ f Scope { .. } -> 60 | fmap (\ ns -> Scope { scopePublic = ns, .. }) (f scopePublic) 61 | 62 | privateVisibility = V $ \ f Scope { .. } -> 63 | fmap (\ ns -> Scope { scopePrivate = ns, .. }) (f scopePrivate) 64 | 65 | emptyScope :: Namespace -> [T.Text] -> Scope 66 | emptyScope scopeNS scopePrefix = 67 | Scope { scopePublic = mempty 68 | , scopePrivate = mempty 69 | , .. } 70 | 71 | topScope :: [T.Text] -> Scope 72 | topScope pfx = emptyScope (packNamespace pfx) pfx 73 | 74 | localScope :: Namespace -> [T.Text] -> Scope 75 | localScope outer pfx = emptyScope (outer `dot` packNamespace pfx) pfx 76 | 77 | declScope :: Scope -> Scope 78 | declScope parent = emptyScope (scopeNS parent) (scopePrefix parent) 79 | 80 | mergeScope :: Scope -> [Scope] -> [Scope] 81 | mergeScope _ [] = [] -- XXX: is this just an error? 82 | mergeScope s (parent : rest) = 83 | parent { scopePublic = qualify (scopePrefix s) (scopePublic s) 84 | `mappend` scopePublic parent 85 | } : rest 86 | 87 | -- INVARIANT: rwContext should never be empty 88 | data RW = RW { rwContext :: [Scope] 89 | , rwVisibility :: Visibility 90 | } 91 | 92 | pushScope :: Scope -> RW -> RW 93 | pushScope scope rw = rw { rwContext = scope : rwContext rw } 94 | 95 | popScope :: RW -> RW 96 | popScope rw = 97 | case rwContext rw of 98 | scope : rest -> rw { rwContext = mergeScope scope rest } 99 | _ -> rw 100 | 101 | currentScope :: Lens' RW Scope 102 | currentScope f rw = 103 | case rwContext rw of 104 | scope : rest -> fmap (\ scope' -> rw { rwContext = scope' : rest }) (f scope) 105 | _ -> panic (text "Scope stack underflow") 106 | 107 | 108 | newtype RN a = RN { unRN :: StateT RW Dang a 109 | } deriving (Functor,Applicative,Monad,Alternative,MonadPlus) 110 | 111 | instance BaseM RN Dang where 112 | inBase m = RN (inBase m) 113 | {-# INLINE inBase #-} 114 | 115 | rename :: [T.Text] -> RN a -> Dang a 116 | rename ns (RN m) = 117 | do (a,_) <- runM m RW { rwContext = [topScope ns] 118 | , rwVisibility = publicVisibility } 119 | return a 120 | 121 | -- | Enter a module, and push a new scope on the context stack. 122 | withModuleScope :: IdentOf Parsed -> (Name -> RN a) -> RN a 123 | withModuleScope lpname body = 124 | do n <- newModuleBind lpname 125 | ns <- currentNamespace 126 | RN (sets_ (pushScope (localScope ns (pnameNamespace lpname)))) 127 | a <- body n 128 | RN (sets_ popScope) 129 | return a 130 | 131 | -- | A local scope, introduced by a declaration. 132 | withDeclScope :: RN a -> RN a 133 | withDeclScope body = 134 | do RN (sets_ (\ rw -> pushScope (declScope (view currentScope rw)) rw)) 135 | a <- body 136 | RN (sets_ popScope) 137 | return a 138 | 139 | 140 | -- | The global namespace of the current scope. 141 | currentNamespace :: RN Namespace 142 | currentNamespace = RN $ 143 | do RW { .. } <- get 144 | case rwContext of 145 | scope : _ -> return (scopeNS scope) 146 | _ -> panic (text "Scope stack underflowed") 147 | 148 | 149 | -- | Set visibility. 150 | withVisibility :: Visibility -> RN a -> RN a 151 | withVisibility vis (RN m) = RN $ 152 | do old <- sets (\ rw -> ( rwVisibility rw, rw { rwVisibility = vis })) 153 | a <- m 154 | sets_ (\ rw -> rw { rwVisibility = old }) 155 | return a 156 | 157 | -- | Get visibility. 158 | currentVisibility :: RN Visibility 159 | currentVisibility = RN $ 160 | do RW { rwVisibility = vis } <- get 161 | return vis 162 | 163 | 164 | -- | Make a new module name, for a module within a compilation unit. 165 | -- 166 | -- INVARIANT: this should never be a qualified identifier, as it's only possible 167 | -- to give an unqualified name in the parsed syntax. 168 | newMod :: IdentOf Parsed -> RN Name 169 | newMod lpname = 170 | do ns <- currentNamespace 171 | RN (withSupply (mkModName (Just ns) (expectUnqual lpname) (range lpname))) 172 | 173 | -- | Make a new binding name. 174 | -- 175 | -- INVARIANT: this should never be a qualified identifier, as it's only possible 176 | -- to give an unqualified name in the parsed syntax. 177 | newBind :: IdentOf Parsed -> RN Name 178 | newBind lpname = 179 | do ns <- currentNamespace 180 | RN (withSupply (mkBinding ns (expectUnqual lpname) (range lpname))) 181 | 182 | -- | Make a new name for a parameter. 183 | -- 184 | -- INVARIANT: this should never be a qualified identifier. 185 | newParam :: ParamSource -> IdentOf Parsed -> RN Name 186 | newParam src lpname = 187 | RN (withSupply (mkParam src (expectUnqual lpname) (range lpname))) 188 | 189 | 190 | addPName :: (T.Text -> Def) -> Visibility -> IdentOf Parsed -> Name -> RN () 191 | addPName mkDef vis lpname n = 192 | RN (sets_ (over (currentScope . unV vis) (insertPName mkDef lpname [n]))) 193 | 194 | addValue, addMod, addType :: Visibility -> IdentOf Parsed -> Name -> RN () 195 | addValue = addPName DefVal 196 | addMod = addPName DefMod 197 | addType = addPName DefType 198 | 199 | 200 | -- | Introduce a value-level name. 201 | newValueBind :: IdentOf Parsed -> RN (IdentOf Renamed) 202 | newValueBind lpname = 203 | do n <- newBind lpname 204 | vis <- currentVisibility 205 | addValue vis lpname n 206 | return n 207 | 208 | -- | Introduce a value-level parameter. 209 | newValueParam :: ParamSource -> IdentOf Parsed -> RN (IdentOf Renamed) 210 | newValueParam parent lpname = 211 | do n <- newParam parent lpname 212 | addValue privateVisibility lpname n 213 | return n 214 | 215 | -- | Introduce a module name. 216 | newModuleBind :: IdentOf Parsed -> RN (IdentOf Renamed) 217 | newModuleBind lpname = 218 | do n <- newMod lpname 219 | vis <- currentVisibility 220 | addMod vis lpname n 221 | return n 222 | 223 | -- | Introduce a module parameter. 224 | newFunctorParam :: ParamSource -> IdentOf Parsed -> RN (IdentOf Renamed) 225 | newFunctorParam parent lpname = 226 | do n <- newParam parent lpname 227 | addMod privateVisibility lpname n 228 | return n 229 | 230 | -- | Introduce a type-level name. 231 | newTypeBind :: IdentOf Parsed -> RN (IdentOf Renamed) 232 | newTypeBind lpname = 233 | do n <- newBind lpname 234 | vis <- currentVisibility 235 | addType vis lpname n 236 | return n 237 | 238 | -- | Introduce a type-level parameter. 239 | newTypeParam :: ParamSource -> IdentOf Parsed -> RN (IdentOf Renamed) 240 | newTypeParam parent lpname = 241 | do n <- newParam parent lpname 242 | addType privateVisibility lpname n 243 | return n 244 | 245 | 246 | -- | Panic if a qualified name is given. 247 | expectUnqual :: PName -> T.Text 248 | expectUnqual (PUnqual _ n) = n 249 | expectUnqual (PQual _ _ _) = panic (text "Expected an unqualified name") 250 | 251 | 252 | -- Renaming -------------------------------------------------------------------- 253 | 254 | type Rename f = f Parsed -> RN (f Renamed) 255 | 256 | -- | Special renaming for the top-most module. 257 | rnTopModule :: Rename Module 258 | rnTopModule m = 259 | withLoc (modMeta m) $ 260 | -- NOTE: don't actually record the name in the environment, as we're 261 | -- currently inside this module. 262 | do n' <- newMod (modName m) 263 | rnModuleAux n' m 264 | 265 | rnModule :: Rename Module 266 | rnModule m = 267 | withLoc (modMeta m) $ 268 | withModuleScope (modName m) $ \ n' -> 269 | rnModuleAux n' m 270 | 271 | rnModuleAux :: Name -> Rename Module 272 | rnModuleAux n' Module { .. } = 273 | do bs' <- traverse rnDecl modDecls 274 | return Module { modName = n' 275 | , modMeta = modMeta 276 | , modRequires = [] 277 | , modDecls = bs' 278 | } 279 | 280 | rnDecl :: Rename Decl 281 | 282 | rnDecl (DBind loc bind) = withLoc loc (DBind loc <$> rnBind bind) 283 | 284 | rnDecl (DSig _ sig) = 285 | panic $ text "Unexpected DSig remaining, bug in resolveSignatures?" $$ 286 | pp (sigName sig) 287 | 288 | rnDecl (DData loc dta) = withLoc loc (DData loc <$> rnData dta) 289 | 290 | rnDecl (DSyn loc syn) = withLoc loc (DSyn loc <$> rnSyn syn) 291 | 292 | rnDecl (DModBind loc lname e) = 293 | withLoc loc $ 294 | withModuleScope lname $ \ name -> 295 | DModBind loc name <$> rnModExpr (Just (FromMod name)) e 296 | 297 | rnDecl (DModType loc lname ty) = 298 | withLoc loc $ 299 | withModuleScope lname $ \ name -> 300 | DModType loc name <$> rnModType ty 301 | 302 | 303 | rnModExpr :: Maybe ParamSource -> Rename ModExpr 304 | rnModExpr mbParent = go 305 | where 306 | go (MEName loc n) = withLoc loc $ 307 | MEName loc <$> rnModName n 308 | 309 | go (MEApp loc f x) = withLoc loc $ 310 | MEApp loc <$> go f <*> go x 311 | 312 | go (MEStruct loc s) = withLoc loc (MEStruct loc <$> rnModStruct s) 313 | 314 | go (MEFunctor loc p ty e) = withLoc loc $ 315 | do p' <- newFunctorParam (fromMaybe (FromFunctor loc) mbParent) p 316 | ty' <- rnModType ty 317 | e' <- go e 318 | return (MEFunctor loc p' ty' e') 319 | 320 | go (MEConstraint loc m ty) = withLoc loc $ 321 | MEConstraint loc <$> go m <*> rnModType ty 322 | 323 | 324 | -- | Rename the declarations held within a struct. 325 | rnModStruct :: Rename ModStruct 326 | rnModStruct (ModStruct loc es) = withLoc loc $ 327 | ModStruct loc <$> traverse rnDecl es 328 | 329 | 330 | rnModType :: Rename ModType 331 | 332 | rnModType (MTVar loc n) = 333 | MTVar loc <$> rnModName n 334 | 335 | rnModType (MTSig loc sig) = withLoc loc $ 336 | MTSig loc <$> traverse rnModSpec sig 337 | 338 | rnModType (MTFunctor loc p ty rty) = undefined 339 | 340 | 341 | rnModSpec :: Rename ModSpec 342 | rnModSpec (MSSig loc sig) = withLoc loc (MSKind loc <$> rnSig sig) 343 | rnModSpec (MSKind loc sig) = withLoc loc (MSKind loc <$> rnSig sig) 344 | rnModSpec (MSData loc dat) = withLoc loc (MSData loc <$> rnData dat) 345 | rnModSpec (MSMod loc n ty) = withLoc loc $ 346 | MSMod loc <$> newModuleBind n <*> rnModType ty 347 | 348 | 349 | -- | Introduce names from a binding. 350 | introBind :: Bind Parsed -> RN () 351 | introBind Bind { .. } = 352 | do _ <- withLoc bMeta (newValueBind bName) 353 | return () 354 | 355 | -- | Rename a binding. 356 | rnBind :: Rename Bind 357 | rnBind b = 358 | do introBind b 359 | rnBindAux b 360 | 361 | -- | Rename a binding, assuming that it's name has already been introduced. 362 | rnBindAux :: Rename Bind 363 | rnBindAux Bind { .. } = 364 | withLoc bMeta $ 365 | withDeclScope $ 366 | do n' <- rnValueName bName 367 | ps' <- traverse (rnPat (FromBind n')) bParams 368 | b' <- rnExpr bBody 369 | ty' <- traverse (rnSchema (FromBind n')) bSig 370 | return Bind { bName = n' 371 | , bParams = ps' 372 | , bBody = b' 373 | , bSig = ty' 374 | , .. } 375 | 376 | -- | Rename a value signature from a module type. This introduces a fresh name 377 | -- for the name bound by the signature, as there is no accompanying value 378 | -- binding at this point. 379 | rnSig :: Rename Sig 380 | rnSig Sig { .. } = withLoc sigMeta $ 381 | do name <- newValueBind sigName 382 | withDeclScope $ 383 | do ty <- rnSchema (FromType name) sigSchema 384 | return Sig { sigName = name, sigSchema = ty, .. } 385 | 386 | 387 | -- | Introduce names for the type that is introduced, as well as for each 388 | -- constructor. Rename type parameters for each constructor. 389 | rnData :: Rename Data 390 | rnData Data { .. } = withLoc dMeta $ 391 | do ty <- newTypeBind dName 392 | ps <- mapM (newTypeParam (FromType ty)) dParams 393 | cs <- mapM rnConstr dConstrs 394 | return Data { dName = ty 395 | , dParams = ps 396 | , dConstrs = cs 397 | , .. } 398 | 399 | 400 | rnConstr :: Rename Constr 401 | rnConstr Constr { .. } = withLoc cMeta $ 402 | do name <- newValueBind cName 403 | ps <- mapM rnType cParams 404 | return Constr { cName = name, cParams = ps, .. } 405 | 406 | 407 | -- | Rename a type synonym. 408 | rnSyn :: Rename Syn 409 | rnSyn Syn { .. } = withLoc synMeta $ 410 | do name' <- newTypeBind synName 411 | ps' <- mapM (newTypeParam (FromType name')) synParams 412 | ty' <- rnType synType 413 | return Syn { synName = name', synParams = ps', synType = ty', .. } 414 | 415 | 416 | rnSchema :: ParamSource -> Rename Schema 417 | rnSchema src (Schema loc ps ty) = withLoc loc $ 418 | Schema loc <$> traverse (newTypeParam src) ps 419 | <*> rnType ty 420 | 421 | 422 | rnType :: Rename Type 423 | rnType (TCon loc n) = withLoc loc $ 424 | TCon loc <$> rnTypeName n 425 | 426 | rnType (TVar loc v) = withLoc loc $ 427 | TVar loc <$> rnTypeName v 428 | 429 | rnType (TApp loc f ps) = withLoc loc $ 430 | TApp loc <$> rnType f <*> traverse rnType ps 431 | 432 | rnType (TFun loc a b) = withLoc loc $ 433 | TFun loc <$> rnType a <*> rnType b 434 | 435 | 436 | rnPat :: ParamSource -> Rename Pat 437 | 438 | rnPat parent (PVar loc v) = 439 | withLoc loc (PVar loc <$> newValueParam parent v) 440 | 441 | rnPat _ (PWild loc) = 442 | return (PWild loc) 443 | 444 | rnPat parent (PCon loc con ps) = 445 | withLoc loc (PCon loc <$> rnValueName con <*> traverse (rnPat parent) ps) 446 | 447 | rnExpr :: Rename Expr 448 | rnExpr (EVar loc n) = withLoc loc (EVar loc <$> rnValueName n) 449 | rnExpr (ECon loc n) = withLoc loc (ECon loc <$> rnValueName n) 450 | rnExpr (EApp loc f xs) = withLoc loc (EApp loc <$> rnExpr f <*> traverse rnExpr xs) 451 | 452 | rnExpr (EAbs loc xs m) = withLoc loc $ 453 | EAbs loc <$> traverse (rnPat (FromLambda loc)) xs <*> rnExpr m 454 | 455 | rnExpr (ELit loc lit) = withLoc loc (ELit loc <$> rnLit lit) 456 | rnExpr (ELet loc lds e) = 457 | withLoc loc $ 458 | rnLetDecls lds $ \ lds' -> 459 | ELet loc lds' <$> rnExpr e 460 | 461 | rnExpr (ECase loc e m) = 462 | withLoc loc $ 463 | ECase loc <$> rnExpr e <*> rnMatch (FromCase loc) m 464 | 465 | 466 | rnMatch :: ParamSource -> Rename Match 467 | rnMatch parent = go 468 | where 469 | go (MPat loc p m) = withLoc loc $ 470 | MPat loc <$> rnPat parent p <*> go m 471 | 472 | go (MSplit loc l r) = withLoc loc $ 473 | MSplit loc <$> go l <*> go r 474 | 475 | go (MFail loc) = 476 | pure (MFail loc) 477 | 478 | go (MExpr loc e) = withLoc loc $ 479 | MExpr loc <$> rnExpr e 480 | 481 | -- | Introduce names for all declarations in the block, then rename each 482 | -- declaration. 483 | rnLetDecls :: [LetDecl Parsed] -> ([LetDecl Renamed] -> RN a) -> RN a 484 | rnLetDecls lds body = 485 | do introBinds lds 486 | lds' <- traverse rnLetDecl lds 487 | body lds' 488 | 489 | where 490 | 491 | introBinds [] = return () 492 | 493 | introBinds (LDBind _ b : rest) = 494 | do introBind b 495 | introBinds rest 496 | 497 | -- signatures don't introduce bindings 498 | introBinds (LDSig _ _ : rest) = 499 | introBinds rest 500 | 501 | 502 | -- | Rename a single let declaration. 503 | -- 504 | -- NOTE: binding names will be introduced by the let block, as let is recursive. 505 | rnLetDecl :: Rename LetDecl 506 | rnLetDecl (LDBind loc b) = withLoc loc (LDBind loc <$> rnBindAux b) 507 | rnLetDecl (LDSig loc s) = 508 | panic $ text "Unexpected LDSig remaining, bug in resolveSignatures?" $$ 509 | pp (sigName s) 510 | 511 | 512 | rnLit :: Rename Literal 513 | rnLit (LInt loc a b) = pure (LInt loc a b) 514 | 515 | 516 | -- | Find the canonical name for this value-level variable. 517 | rnValueName :: IdentOf Parsed -> RN (IdentOf Renamed) 518 | rnValueName = rnPName DefVal 519 | 520 | rnTypeName :: IdentOf Parsed -> RN (IdentOf Renamed) 521 | rnTypeName = rnPName DefType 522 | 523 | -- | Find the canonical name of this module name. 524 | rnModName :: HasCallStack => IdentOf Parsed -> RN (IdentOf Renamed) 525 | rnModName = rnPName DefMod 526 | 527 | 528 | rnPName :: (T.Text -> Def) -> IdentOf Parsed -> RN (IdentOf Renamed) 529 | rnPName mkDef lpname = 530 | do RW { rwContext = ctx } <- RN get 531 | case resolve ctx of 532 | Just [] -> panic (text "Malformed name scope") 533 | Just ns -> return (head ns) 534 | Nothing -> missingBinding lpname 535 | 536 | where 537 | 538 | resolve (scope:rest) = check (scopePrivate scope) 539 | $ check (scopePublic scope) 540 | $ go rest 541 | 542 | resolve [] = panic (text "Invalid scope context") 543 | 544 | check names tryOther = 545 | do NameNode mb _ <- lookupPName mkDef lpname names 546 | mb 547 | <|> 548 | tryOther 549 | 550 | go [] = Nothing 551 | go (scope : rest) = check (scopePublic scope) (go rest) 552 | 553 | 554 | -- Errors ---------------------------------------------------------------------- 555 | 556 | missingBinding :: IdentOf Parsed -> RN (IdentOf Renamed) 557 | missingBinding lpname = withLoc lpname $ 558 | do addError ErrRnUnknown (pp lpname) 559 | ns <- currentNamespace 560 | loc <- askLoc 561 | RN (withSupply (mkUnknown (Declaration (ModInfo ns)) lpname loc)) 562 | -------------------------------------------------------------------------------- /src/Dang/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE ConstraintKinds #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE ParallelListComp #-} 9 | 10 | module Dang.Monad ( 11 | Dang(), DangM, runDang, 12 | io, 13 | askLoc, withLoc, 14 | try, 15 | 16 | -- ** Messages 17 | Messages, 18 | module Dang.Message, 19 | failErrors, 20 | collectMessages, 21 | addError, 22 | addWarning, 23 | putMessages, 24 | getMessages, 25 | 26 | -- ** Re-exported 27 | mzero, 28 | mplus, 29 | ) where 30 | 31 | import Dang.Message 32 | import Dang.Syntax.Location (SourceRange,HasRange(..),emptyRange) 33 | import Dang.Unique 34 | import Dang.Utils.PP 35 | import Dang.Utils.Panic 36 | 37 | import Control.Applicative (Alternative(..)) 38 | import qualified Control.Exception as X 39 | import Control.Monad (MonadPlus(..),guard) 40 | import Data.IORef 41 | (IORef,newIORef,readIORef,writeIORef,atomicModifyIORef' 42 | ,modifyIORef') 43 | import qualified Data.Sequence as Seq 44 | import Data.Typeable (Typeable) 45 | import MonadLib (RunM(..), BaseM(..), ReaderT, ask) 46 | 47 | 48 | type Messages = Seq.Seq Message 49 | 50 | data RO = RO { roLoc :: !(IORef [SourceRange]) 51 | , roMsgs :: !(IORef Messages) 52 | , roSupply :: !(IORef Supply) 53 | } 54 | 55 | newRO :: IO RO 56 | newRO = 57 | do roLoc <- newIORef [] 58 | roMsgs <- newIORef Seq.empty 59 | roSupply <- newIORef initialSupply 60 | return RO { .. } 61 | 62 | -- | Build an IO action that restores the previous state of the environment. 63 | -- Messages aren't cleared out by the restore action, as it's useful to capture 64 | -- the messages of a failed computation. 65 | mkRestore :: RO -> IO (IO ()) 66 | mkRestore RO { .. } = 67 | do loc <- readIORef roLoc 68 | sup <- readIORef roSupply 69 | return $ do writeIORef roLoc loc 70 | writeIORef roSupply sup 71 | 72 | newtype Dang a = Dang { unDang :: ReaderT RO IO a 73 | } deriving (Functor,Applicative,Monad) 74 | 75 | instance Alternative Dang where 76 | empty = mzero 77 | (<|>) = mplus 78 | 79 | instance MonadPlus Dang where 80 | mzero = Dang (inBase (X.throwIO DangError)) 81 | mplus a b = Dang $ 82 | do ro <- ask 83 | restore <- inBase (mkRestore ro) 84 | inBase (runDang' ro a `X.catch` \ DangError -> restore >> runDang' ro b) 85 | 86 | instance BaseM Dang Dang where 87 | inBase = id 88 | 89 | instance RunM Dang a (Dang a) where 90 | runM = id 91 | 92 | instance SupplyM Dang where 93 | withSupply f = 94 | do RO { .. } <- Dang ask 95 | io (atomicModifyIORef' roSupply f) 96 | 97 | -- | The identity to the 'Alternative' and 'MonadPlus' instances. 98 | data DangError = DangError 99 | deriving (Show,Typeable) 100 | 101 | instance X.Exception DangError 102 | 103 | type DangM m = (MonadPlus m, BaseM m Dang) 104 | 105 | runDang :: Dang a -> IO a 106 | runDang m = 107 | do ro <- newRO 108 | runDang' ro m 109 | 110 | runDang' :: RO -> Dang a -> IO a 111 | runDang' ro m = 112 | do res <- X.try (runM (unDang m) ro) 113 | case res of 114 | Right a -> return a 115 | Left p -> 116 | do print (ppr (p :: Panic)) 117 | X.throwIO DangError 118 | 119 | io :: BaseM m Dang => IO a -> m a 120 | io m = inBase (Dang (inBase m)) 121 | 122 | try :: DangM dang => dang a -> dang (Maybe a) 123 | try m = (Just <$> m) `mplus` pure Nothing 124 | 125 | 126 | -- Location Management --------------------------------------------------------- 127 | 128 | -- | Retrieve the current source location. 129 | askLoc :: DangM dang => dang SourceRange 130 | askLoc = 131 | do RO { .. } <- inBase (Dang ask) 132 | locs <- io (readIORef roLoc) 133 | case locs of 134 | loc:_ -> return loc 135 | _ -> return emptyRange 136 | 137 | -- | Run a sub-computation with a new source location. 138 | withLoc :: (HasRange range, DangM dang) => range -> dang a -> dang a 139 | withLoc r body = 140 | do RO { .. } <- inBase (Dang ask) 141 | orig <- io (atomicModifyIORef' roLoc (\ orig -> (range r : orig, orig))) 142 | a <- body 143 | io (modifyIORef' roLoc (const orig)) 144 | return a 145 | 146 | 147 | -- Errors and Warnings --------------------------------------------------------- 148 | 149 | -- | Fail if errors are produced by the action given. Any warnings generated are 150 | failErrors :: DangM dang => dang a -> dang a 151 | failErrors m = 152 | do a <- m 153 | ms <- getMessages 154 | guard (not (any isError ms)) 155 | return a 156 | 157 | collectMessages :: DangM dang => dang a -> dang (a,Messages) 158 | collectMessages m = 159 | do RO { .. } <- inBase (Dang ask) 160 | orig <- io (atomicModifyIORef' roMsgs (\ orig -> (Seq.empty, orig))) 161 | a <- m 162 | msgs <- io (atomicModifyIORef' roMsgs (\ msgs -> (orig, msgs))) 163 | return (a,msgs) 164 | 165 | getMessages :: DangM dang => dang Messages 166 | getMessages = inBase $ Dang $ 167 | do RO { .. } <- ask 168 | inBase (readIORef roMsgs) 169 | 170 | putMessages :: DangM dang => Messages -> dang () 171 | putMessages ms = inBase $ Dang $ 172 | do RO { .. } <- ask 173 | inBase (modifyIORef' roMsgs (ms Seq.><)) 174 | 175 | addMessage :: (PP msg, DangM dang) => MessageType -> msg -> dang () 176 | addMessage msgType msg = inBase $ 177 | do msgSource <- askLoc 178 | putMessages (Seq.singleton Message { msgDoc = pp msg, .. }) 179 | 180 | addError :: (PP msg, DangM dang) => Error -> msg -> dang () 181 | addError e = addMessage (Error e) 182 | 183 | addWarning :: (PP msg, DangM dang) => Warning -> msg -> dang () 184 | addWarning w = addMessage (Warning w) 185 | -------------------------------------------------------------------------------- /src/Dang/Syntax/.gitignore: -------------------------------------------------------------------------------- 1 | Parser.hs 2 | -------------------------------------------------------------------------------- /src/Dang/Syntax/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE UndecidableInstances #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE ConstraintKinds #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | 12 | {-# OPTIONS_GHC -fconstraint-solver-iterations=20 #-} 13 | 14 | module Dang.Syntax.AST where 15 | 16 | import Dang.AST 17 | import Dang.Syntax.Location 18 | import Dang.Utils.PP 19 | 20 | import Data.List (intersperse) 21 | import qualified Data.Text as T 22 | import GHC.Generics (Generic) 23 | 24 | 25 | -- Syntax and Metadata --------------------------------------------------------- 26 | 27 | -- | The syntax descriptor for parsed modules. 28 | data Parsed 29 | 30 | type instance IdentOf Parsed = PName 31 | type instance TypeOf Parsed = Type Parsed 32 | type instance SchemaOf Parsed = Schema Parsed 33 | type instance MetaOf Parsed = SourceRange 34 | 35 | 36 | -- AST ------------------------------------------------------------------------- 37 | 38 | -- | Parsed names, either qualified or unqualified. 39 | data PName = PUnqual !SourceRange !T.Text 40 | | PQual !SourceRange ![T.Text] !T.Text 41 | deriving (Eq,Show,Generic) 42 | 43 | instance Ord PName where 44 | compare (PUnqual _ a) (PUnqual _ b) = compare a b 45 | compare PUnqual{} _ = LT 46 | 47 | compare (PQual _ as a) (PQual _ bs b) = 48 | case compare as bs of 49 | EQ -> compare a b 50 | x -> x 51 | compare PQual{} _ = GT 52 | 53 | pnameNamespace :: PName -> [T.Text] 54 | pnameNamespace (PUnqual _ i) = [i] 55 | pnameNamespace (PQual _ ns i) = ns ++ [i] 56 | 57 | -- | A parsed top-level module. 58 | type PModule = Module Parsed 59 | 60 | data Module syn = Module { modMeta :: MetaOf syn 61 | , modName :: IdentOf syn 62 | , modRequires :: [Require syn] 63 | , modDecls :: [Decl syn] 64 | } deriving (Generic) 65 | 66 | data Require syn = Require { reqMeta :: MetaOf syn 67 | , reqModule :: IdentOf syn 68 | , reqOpen :: Bool 69 | } 70 | 71 | data ModStruct syn = ModStruct { msMeta :: MetaOf syn 72 | , msElems :: [Decl syn] 73 | } deriving (Generic) 74 | 75 | data Decl syn = DBind (MetaOf syn) (Bind syn) 76 | | DSig (MetaOf syn) (Sig syn) 77 | | DData (MetaOf syn) (Data syn) 78 | | DSyn (MetaOf syn) (Syn syn) 79 | | DModBind (MetaOf syn) (IdentOf syn) (ModExpr syn) 80 | | DModType (MetaOf syn) (IdentOf syn) (ModType syn) 81 | deriving (Generic) 82 | 83 | data Bind syn = Bind { bMeta :: MetaOf syn 84 | , bName :: IdentOf syn 85 | , bSig :: Maybe (SchemaOf syn) 86 | , bParams :: [Pat syn] 87 | , bBody :: Expr syn 88 | } deriving (Generic) 89 | 90 | data Sig syn = Sig { sigMeta :: MetaOf syn 91 | , sigName :: IdentOf syn 92 | , sigSchema :: SchemaOf syn 93 | } deriving (Generic) 94 | 95 | -- | A type synonym. 96 | data Syn syn = Syn { synMeta :: MetaOf syn 97 | , synName :: IdentOf syn 98 | , synParams :: [IdentOf syn] 99 | , synType :: TypeOf syn 100 | } deriving (Generic) 101 | 102 | data ModType syn = MTVar (MetaOf syn) (IdentOf syn) 103 | | MTSig (MetaOf syn) (ModSig syn) 104 | | MTFunctor (MetaOf syn) (IdentOf syn) (ModType syn) (ModType syn) 105 | -- XXX add with-constraints 106 | deriving (Generic) 107 | 108 | type ModSig syn = [ModSpec syn] 109 | 110 | data ModSpec syn = MSSig (MetaOf syn) (Sig syn) 111 | | MSKind (MetaOf syn) (Sig syn) 112 | | MSData (MetaOf syn) (Data syn) 113 | | MSMod (MetaOf syn) (IdentOf syn) (ModType syn) 114 | deriving (Generic) 115 | 116 | data ModExpr syn = MEName (MetaOf syn) (IdentOf syn) 117 | | MEApp (MetaOf syn) (ModExpr syn) (ModExpr syn) 118 | | MEStruct (MetaOf syn) (ModStruct syn) 119 | | MEFunctor (MetaOf syn) (IdentOf syn) (ModType syn) (ModExpr syn) 120 | | MEConstraint (MetaOf syn) (ModExpr syn) (ModType syn) 121 | deriving (Generic) 122 | 123 | data Match syn = MPat (MetaOf syn) (Pat syn) (Match syn) 124 | | MSplit (MetaOf syn) (Match syn) (Match syn) 125 | | MFail (MetaOf syn) 126 | | MExpr (MetaOf syn) (Expr syn) 127 | deriving (Generic) 128 | 129 | data Pat syn = PVar (MetaOf syn) (IdentOf syn) 130 | | PWild (MetaOf syn) 131 | | PCon (MetaOf syn) (IdentOf syn) [Pat syn] 132 | deriving (Generic) 133 | 134 | data Expr syn = EVar (MetaOf syn) (IdentOf syn) 135 | | ECon (MetaOf syn) (IdentOf syn) 136 | | EApp (MetaOf syn) (Expr syn) [Expr syn] 137 | | EAbs (MetaOf syn) [Pat syn] (Expr syn) 138 | | ELit (MetaOf syn) (Literal syn) 139 | | ELet (MetaOf syn) [LetDecl syn] (Expr syn) 140 | | ECase (MetaOf syn) (Expr syn) (Match syn) 141 | deriving (Generic) 142 | 143 | data LetDecl syn = LDBind (MetaOf syn) (Bind syn) 144 | | LDSig (MetaOf syn) (Sig syn) 145 | -- XXX add open declarations 146 | deriving (Generic) 147 | 148 | data Literal syn = LInt (MetaOf syn) Integer Int -- ^ value and base 149 | deriving (Generic) 150 | 151 | data Data syn = Data { dMeta :: MetaOf syn 152 | , dName :: IdentOf syn 153 | , dParams :: [IdentOf syn] 154 | , dConstrs :: [Constr syn] 155 | } deriving (Generic) 156 | 157 | data Constr syn = Constr { cMeta :: MetaOf syn 158 | , cName :: IdentOf syn 159 | , cParams :: [TypeOf syn] 160 | } deriving (Generic) 161 | 162 | 163 | data Schema syn = Schema (MetaOf syn) [IdentOf syn] (TypeOf syn) 164 | deriving (Generic) 165 | 166 | data Type syn = TCon (MetaOf syn) (IdentOf syn) 167 | | TVar (MetaOf syn) (IdentOf syn) 168 | | TApp (MetaOf syn) (Type syn) [Type syn] 169 | | TFun (MetaOf syn) (Type syn) (Type syn) 170 | deriving (Generic) 171 | 172 | 173 | -- Helpers --------------------------------------------------------------------- 174 | 175 | class HasSig f where 176 | isSig :: f syn -> Bool 177 | 178 | instance HasSig Decl where 179 | isSig DSig{} = True 180 | isSig _ = False 181 | 182 | instance HasSig LetDecl where 183 | isSig LDSig{} = True 184 | isSig _ = False 185 | 186 | 187 | -- Instances ------------------------------------------------------------------- 188 | 189 | deriving instance Cxt Show syn => Show (Module syn) 190 | deriving instance Cxt Show syn => Show (Require syn) 191 | deriving instance Cxt Show syn => Show (ModStruct syn) 192 | deriving instance Cxt Show syn => Show (ModSpec syn) 193 | deriving instance Cxt Show syn => Show (ModExpr syn) 194 | deriving instance Cxt Show syn => Show (ModType syn) 195 | deriving instance Cxt Show syn => Show (Decl syn) 196 | deriving instance Cxt Show syn => Show (Bind syn) 197 | deriving instance Cxt Show syn => Show (Sig syn) 198 | deriving instance Cxt Show syn => Show (Match syn) 199 | deriving instance Cxt Show syn => Show (Pat syn) 200 | deriving instance Cxt Show syn => Show (Expr syn) 201 | deriving instance Cxt Show syn => Show (LetDecl syn) 202 | deriving instance Cxt Show syn => Show (Literal syn) 203 | deriving instance Cxt Show syn => Show (Data syn) 204 | deriving instance Cxt Show syn => Show (Syn syn) 205 | deriving instance Cxt Show syn => Show (Constr syn) 206 | 207 | -- front-end specific types and schemas 208 | deriving instance Cxt Show syn => Show (Schema syn) 209 | deriving instance Cxt Show syn => Show (Type syn) 210 | 211 | 212 | -- Locations ------------------------------------------------------------------- 213 | 214 | instance HasRange (Module Parsed) where 215 | range = modMeta 216 | 217 | instance HasRange (ModType Parsed) where 218 | range (MTVar l _) = l 219 | range (MTSig l _) = l 220 | range (MTFunctor l _ _ _) = l 221 | 222 | instance HasRange (Sig Parsed) where 223 | range Sig { .. } = sigMeta 224 | 225 | instance HasRange (Bind Parsed) where 226 | range Bind { .. } = bMeta 227 | 228 | instance HasRange (Data Parsed) where 229 | range Data { .. } = dMeta 230 | 231 | instance HasRange (Syn Parsed) where 232 | range Syn { .. } = synMeta 233 | 234 | instance HasRange (Constr Parsed) where 235 | range Constr { .. } = cMeta 236 | 237 | instance HasRange (ModSpec Parsed) where 238 | range (MSSig l _) = l 239 | range (MSKind l _) = l 240 | range (MSData l _) = l 241 | range (MSMod l _ _) = l 242 | 243 | instance HasRange (ModExpr Parsed) where 244 | range (MEName l _) = l 245 | range (MEApp l _ _) = l 246 | range (MEStruct l _) = l 247 | range (MEFunctor l _ _ _) = l 248 | range (MEConstraint l _ _) = l 249 | 250 | instance HasRange (Match Parsed) where 251 | range (MPat l _ _) = l 252 | range (MSplit l _ _) = l 253 | range (MFail l) = l 254 | range (MExpr l _) = l 255 | 256 | instance HasRange (Schema Parsed) where 257 | range (Schema l _ _) = l 258 | 259 | instance HasRange (Type Parsed) where 260 | range (TCon l _) = l 261 | range (TVar l _) = l 262 | range (TApp l _ _) = l 263 | range (TFun l _ _) = l 264 | 265 | instance HasRange (Expr Parsed) where 266 | range (EVar l _) = l 267 | range (ECon l _) = l 268 | range (EApp l _ _) = l 269 | range (EAbs l _ _) = l 270 | range (ELit l _) = l 271 | range (ELet l _ _) = l 272 | range (ECase l _ _)= l 273 | 274 | instance HasRange (Pat Parsed) where 275 | range (PVar l _) = l 276 | range (PWild l) = l 277 | range (PCon l _ _) = l 278 | 279 | instance HasRange (ModStruct Parsed) where 280 | range (ModStruct l _) = l 281 | 282 | instance HasRange (Literal Parsed) where 283 | range (LInt l _ _) = l 284 | 285 | instance HasRange PName where 286 | range (PUnqual l _) = l 287 | range (PQual l _ _) = l 288 | 289 | 290 | -- Pretty-printing ------------------------------------------------------------- 291 | 292 | instance PP PName where 293 | ppr (PUnqual _ n) = pp n 294 | ppr (PQual _ ns n) = vcat (intersperse (char '.') (map pp ns)) <> char '.' <> pp n 295 | -------------------------------------------------------------------------------- /src/Dang/Syntax/Format.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Dang.Syntax.Format where 5 | 6 | import Dang.Message (Message(..),MessageType(..),describeMessageType) 7 | import Dang.Syntax.Lexer (lexer,Token(..),Keyword(..),Lexeme(..)) 8 | import Dang.Syntax.Location (Source,SourceRange(..),SourcePos(..)) 9 | import Dang.Utils.PP 10 | 11 | import Data.List (intersperse) 12 | import qualified Data.Text as T 13 | 14 | 15 | formatMessage :: Source -> T.Text -> Message -> Doc 16 | formatMessage src txt (Message ty loc doc) = vcat 17 | [ annotate msgAnn (ppHeading (show (tyDoc <+> pp src <+> pp loc))) 18 | , text "" 19 | , doc 20 | , text "" 21 | , source 22 | , describeMessageType ty 23 | , text "" 24 | , text "" ] 25 | where 26 | (chunk,gutterLen) = formatChunk src start (rangeText cxtLines loc txt) 27 | 28 | source = chunk 29 | $$ nest gutterLen (rangeUnderline msgAnn loc) 30 | $$ text "" 31 | 32 | cxtLines = 3 33 | 34 | (tyDoc,msgAnn) = case ty of 35 | Error{} -> (text "[error]", AnnError) 36 | Warning{} -> (text "[warning]", AnnWarning) 37 | 38 | startLine = max 1 (sourceLine (sourceFrom loc) - fromIntegral cxtLines) 39 | start = (sourceFrom loc) { sourceLine = startLine, sourceColumn = 1 } 40 | 41 | ppHeading msg = 42 | text "--" <+> text msg <+> text (replicate (80 - length msg - 4) '-') 43 | 44 | 45 | -- | Extract the range of text with n context lines, centered around the range 46 | -- provided, from the program text. 47 | rangeText :: 48 | Int {-^ Context lines -} -> 49 | SourceRange {-^ Start region-} -> 50 | T.Text {-^ Source text -} -> 51 | T.Text 52 | 53 | rangeText cxt SourceRange { .. } txt 54 | = T.unlines 55 | $ take keep 56 | $ drop skip 57 | $ T.lines txt 58 | 59 | where 60 | skip = max 0 (sourceLine sourceFrom - cxt - 1) 61 | 62 | keep = sourceLine sourceTo - sourceLine sourceFrom + 1 + cxt 63 | 64 | -- | Generate a single underline for the range specified. 65 | rangeUnderline :: Ann -> SourceRange -> Doc 66 | rangeUnderline ann SourceRange { .. } = 67 | text (replicate (start - 1) ' ') <> annotate ann (text line) 68 | where 69 | start = fromIntegral (sourceColumn sourceFrom) 70 | end = fromIntegral (sourceColumn sourceTo) 71 | 72 | len = end - start 73 | 74 | line | len > 0 = replicate (len + 1) '~' 75 | | otherwise = "^" 76 | 77 | 78 | -- | Draw the space defined by two positions. When a new line is started, invoke 79 | -- the function given to define the gutter. 80 | spaceBetween :: Int -> (Int -> Doc) 81 | -> SourcePos -> SourcePos -> Doc 82 | spaceBetween gutterLen mkGutter = \ start end -> 83 | let spansMultipleLines = sourceLine start < sourceLine end 84 | 85 | newlines 86 | | spansMultipleLines = 87 | text "" $+$ 88 | nest (negate (fromIntegral (sourceColumn start + gutterLen + 1))) 89 | (vcat [ mkGutter i | i <- [ sourceLine start + 1 .. sourceLine end ] ]) 90 | 91 | | otherwise = 92 | emptyDoc 93 | 94 | spaces 95 | | spansMultipleLines = 96 | text (replicate (fromIntegral (sourceColumn end) - 1) ' ') 97 | 98 | | otherwise = 99 | text (replicate (fromIntegral (sourceColumn end - sourceColumn start) - 1) ' ') 100 | 101 | in newlines <> spaces 102 | {-# INLINE spaceBetween #-} 103 | 104 | 105 | -- | Format a chunk of text, and return the length of the line-number gutter. 106 | formatChunk :: Source -> SourcePos -> T.Text -> (Doc,Int) 107 | formatChunk src start chunk = (prefix <> go start toks, pad + 1) 108 | where 109 | 110 | toks = lexer src (Just start) chunk 111 | 112 | pad = length (show (sourceLine loc)) 113 | where 114 | loc | null toks = start 115 | | otherwise = sourceTo (lexemeRange (last toks)) 116 | 117 | gutter row = 118 | let str = show row 119 | num = text (replicate (pad - length str) ' ') <> text str 120 | 121 | in annotate AnnGutter (num <> char '|') 122 | 123 | moveTo = spaceBetween (fromIntegral pad) gutter 124 | 125 | -- the gutter for the first line, and the space to its first token 126 | prefix = gutter (sourceLine start) <> moveTo start { sourceColumn = 1 } start 127 | 128 | go pos (Lexeme { .. }:ts) = 129 | moveTo pos (sourceFrom lexemeRange) 130 | <> formatToken lexemeToken 131 | <> go (sourceTo lexemeRange) ts 132 | 133 | go _ [] = emptyDoc 134 | 135 | 136 | ppQual :: [T.Text] -> T.Text -> Doc 137 | ppQual ns n = hcat (map pp (intersperse (T.pack ".") ns)) <> char '.' <> pp n 138 | 139 | formatToken :: Token -> Doc 140 | formatToken (TUnqualCon c) = pp c 141 | formatToken (TQualCon ns n) = ppQual ns n 142 | formatToken (TUnqualIdent n) = pp n 143 | formatToken (TQualIdent ns n) = ppQual ns n 144 | formatToken (TKeyword kw) = formatKeyword kw 145 | formatToken (TLineComment l) = annotate AnnComment (pp l) 146 | -- XXX handle other bases 147 | formatToken (TNum _ i) = annotate AnnLiteral (pp i) 148 | 149 | formatToken TStart = emptyDoc 150 | formatToken TSep = emptyDoc 151 | formatToken TEnd = emptyDoc 152 | formatToken (TError s) = pp s 153 | 154 | formatKeyword :: Keyword -> Doc 155 | formatKeyword Kmodule = annotate AnnKeyword (text "module") 156 | formatKeyword Kfunctor = annotate AnnKeyword (text "functor") 157 | formatKeyword Ksig = annotate AnnKeyword (text "sig") 158 | formatKeyword Kstruct = annotate AnnKeyword (text "struct") 159 | formatKeyword Kwhere = annotate AnnKeyword (text "where") 160 | formatKeyword Kcolon = annotate AnnPunc (text ":") 161 | formatKeyword Krequire = annotate AnnKeyword (text "require") 162 | formatKeyword Kopen = annotate AnnKeyword (text "open") 163 | formatKeyword Klparen = text "(" 164 | formatKeyword Krparen = text ")" 165 | formatKeyword Krarrow = annotate AnnPunc (text "->") 166 | formatKeyword Kassign = annotate AnnPunc (text "=") 167 | formatKeyword Ktype = annotate AnnKeyword (text "type") 168 | formatKeyword Kdata = annotate AnnKeyword (text "data") 169 | formatKeyword Kforall = annotate AnnKeyword (text "forall") 170 | formatKeyword Kdot = annotate AnnPunc (text ".") 171 | formatKeyword Kcomma = text "," 172 | formatKeyword Kwild = text "_" 173 | formatKeyword Kpipe = annotate AnnPunc (text "|") 174 | formatKeyword Klet = annotate AnnPunc (text "let") 175 | formatKeyword Kin = annotate AnnPunc (text "in") 176 | formatKeyword Kcase = annotate AnnPunc (text "case") 177 | formatKeyword Kof = annotate AnnPunc (text "of") 178 | formatKeyword Klambda = annotate AnnPunc (text "\\") 179 | -------------------------------------------------------------------------------- /src/Dang/Syntax/Lexer.x: -------------------------------------------------------------------------------- 1 | -- vim: ft=haskell 2 | 3 | { 4 | {-# OPTIONS_GHC -w #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | module Dang.Syntax.Lexer ( 9 | Token(..), 10 | Keyword(..), 11 | Lexeme(..), 12 | lexer, 13 | ignoreComments, 14 | ) where 15 | 16 | import Dang.Syntax.AST (PName(..)) 17 | import Dang.Syntax.Location (Source) 18 | import Dang.Utils.Ident 19 | 20 | import AlexTools 21 | import Data.Char (ord,isAscii,isSpace) 22 | import Data.Maybe (fromMaybe) 23 | import Data.Word (Word8) 24 | import qualified Data.Text as T 25 | 26 | } 27 | 28 | $number = [0-9] 29 | 30 | $con_start = [A-Z] 31 | $ident_start = [a-z] 32 | $middle = [A-Za-z0-9_'] 33 | 34 | @con_name = $con_start $middle* 35 | @ident = $ident_start $middle* 36 | @qual = (@con_name \. )+ 37 | 38 | :- 39 | 40 | <0> { 41 | 42 | $white+ ; 43 | 44 | -- only single-line comments for now 45 | "--" .* { emits TLineComment } 46 | 47 | -- keywords 48 | "functor"{ keyword Kfunctor} 49 | "sig" { keyword Ksig } 50 | "struct" { keyword Kstruct } 51 | "module" { keyword Kmodule } 52 | "where" { keyword Kwhere } 53 | "require"{ keyword Krequire} 54 | "open" { keyword Kopen } 55 | "forall" { keyword Kforall } 56 | "type" { keyword Ktype } 57 | "data" { keyword Kdata } 58 | "let" { keyword Klet } 59 | "in" { keyword Kin } 60 | "case" { keyword Kcase } 61 | "of" { keyword Kof } 62 | 63 | -- punctuation 64 | "|" { keyword Kpipe } 65 | ":" { keyword Kcolon } 66 | "=" { keyword Kassign } 67 | "(" { keyword Klparen } 68 | ")" { keyword Krparen } 69 | "->" { keyword Krarrow } 70 | "." { keyword Kdot } 71 | "," { keyword Kcomma } 72 | "_" { keyword Kwild } 73 | "\" { keyword Klambda } 74 | 75 | -- numbers 76 | $number+ { emits (TNum 10 . read . T.unpack) } 77 | 78 | -- names 79 | @qual @con_name { emits (mkQual TQualCon) } 80 | @con_name { emits TUnqualCon } 81 | 82 | @qual @ident { emits (mkQual TQualIdent) } 83 | @ident { emits TUnqualIdent } 84 | 85 | . { emits TError } 86 | 87 | } 88 | 89 | { 90 | 91 | -- Tokens ---------------------------------------------------------------------- 92 | 93 | data Token = TUnqualCon !T.Text 94 | | TQualCon ![T.Text] !T.Text 95 | | TUnqualIdent !T.Text 96 | | TQualIdent ![T.Text] !T.Text 97 | | TKeyword !Keyword 98 | | TNum Int Integer 99 | | TLineComment !T.Text 100 | | TStart 101 | | TSep 102 | | TEnd 103 | | TError !T.Text -- ^ Lexical error 104 | deriving (Eq,Show) 105 | 106 | isComment :: Token -> Bool 107 | isComment TLineComment{} = True 108 | isComment _ = False 109 | 110 | ignoreComments :: [Lexeme Token] -> [Lexeme Token] 111 | ignoreComments = filter (not . isComment . lexemeToken) 112 | 113 | mkQual :: ([T.Text] -> T.Text -> Token) -> T.Text -> Token 114 | mkQual mk txt = 115 | case T.splitOn "." txt of 116 | [n] -> mk [] n 117 | [] -> error "impossible" 118 | ns -> mk (init ns) (last ns) 119 | 120 | data Keyword = Kmodule 121 | | Kfunctor 122 | | Ksig 123 | | Kstruct 124 | | Kwhere 125 | | Kcolon 126 | | Krequire 127 | | Kopen 128 | | Klparen 129 | | Krparen 130 | | Krarrow 131 | | Kassign 132 | | Ktype 133 | | Kdata 134 | | Kforall 135 | | Kdot 136 | | Kcomma 137 | | Kwild 138 | | Kpipe 139 | | Klet 140 | | Kin 141 | | Klambda 142 | | Kcase 143 | | Kof 144 | deriving (Eq,Show) 145 | 146 | 147 | -- Lexer ----------------------------------------------------------------------- 148 | 149 | mkConfig :: LexerConfig Mode Token 150 | mkConfig = 151 | LexerConfig { lexerInitialState = Normal 152 | , lexerStateMode = modeToInt 153 | , lexerEOF = \ _ -> [] } 154 | 155 | lexer :: Source -> Maybe SourcePos -> T.Text -> [Lexeme Token] 156 | lexer src mbPos bytes = 157 | $makeLexer mkConfig $ 158 | case mbPos of 159 | Just pos -> (initialInput src bytes) { inputPos = pos } 160 | Nothing -> initialInput src bytes 161 | 162 | emits :: (T.Text -> Token) -> Action Mode [Lexeme Token] 163 | emits mkToken = 164 | do lexemeText <- matchText 165 | lexemeRange <- matchRange 166 | return [Lexeme { lexemeToken = mkToken lexemeText, .. }] 167 | 168 | token :: Token -> Action Mode [Lexeme Token] 169 | token tok = emits (const tok) 170 | 171 | keyword :: Keyword -> Action Mode [Lexeme Token] 172 | keyword k = token (TKeyword k) 173 | 174 | 175 | -- Lexer Modes ----------------------------------------------------------------- 176 | 177 | data Mode = Normal 178 | deriving (Show) 179 | 180 | modeToInt :: Mode -> Int 181 | modeToInt Normal = 0 182 | 183 | 184 | -- Utility --------------------------------------------------------------------- 185 | 186 | byteForChar :: Char -> Word8 187 | byteForChar c 188 | | isAscii c = fromIntegral (ord c) 189 | | otherwise = non_graphic 190 | 191 | where 192 | 193 | non_graphic = 0 194 | 195 | alexGetByte = makeAlexGetByte $ \ c -> 196 | if isAscii c 197 | then toEnum (fromEnum c) 198 | else 0x1 199 | 200 | } 201 | -------------------------------------------------------------------------------- /src/Dang/Syntax/Location.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Dang.Syntax.Location ( 4 | Source, interactive, 5 | SourceRange(..), HasRange(..), prettySourceRange, emptyRange, 6 | SourcePos(..), prettySourcePos, startPos, emptyPos, 7 | (<->), 8 | listRange 9 | ) where 10 | 11 | import AlexTools 12 | import qualified Data.Text as T 13 | import GHC.Stack (HasCallStack) 14 | 15 | type Source = T.Text 16 | 17 | interactive :: Source 18 | interactive = T.pack "" 19 | 20 | emptyPos :: SourcePos 21 | emptyPos = startPos T.empty 22 | 23 | emptyRange :: SourceRange 24 | emptyRange = SourceRange { sourceFrom = emptyPos, sourceTo = emptyPos } 25 | 26 | listRange :: (HasCallStack,HasRange range) => [range] -> SourceRange 27 | listRange [] = emptyRange 28 | listRange xs = range (last xs) 29 | -------------------------------------------------------------------------------- /src/Dang/Syntax/Parser.y: -------------------------------------------------------------------------------- 1 | -- vim: ft=haskell 2 | 3 | { 4 | {-# OPTIONS_GHC -w #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE PatternSynonyms #-} 10 | 11 | module Dang.Syntax.Parser ( 12 | parseModule, 13 | lexWithLayout, 14 | ) where 15 | 16 | import Dang.Monad 17 | import Dang.AST 18 | import Dang.Syntax.AST 19 | import Dang.Syntax.Lexer 20 | import Dang.Syntax.Location 21 | import Dang.Utils.Ident 22 | import Dang.Utils.PP (text) 23 | import Dang.Utils.Panic 24 | 25 | import Data.Maybe (fromMaybe) 26 | import qualified Data.Text as T 27 | import Text.Layout.OffSides (Layout(..),layout,wrapToken) 28 | 29 | } 30 | 31 | 32 | %tokentype { Lexeme Token } 33 | 34 | %token 35 | QUAL_CON { $$ @ Lexeme { lexemeToken = TQualCon _ _ } } 36 | CON { $$ @ Lexeme { lexemeToken = TUnqualCon _ } } 37 | UNQUAL { $$ @ Lexeme { lexemeToken = TUnqualIdent _ } } 38 | QUAL { $$ @ Lexeme { lexemeToken = TQualIdent _ _ } } 39 | NUM { $$ @ Lexeme { lexemeToken = TNum _ _ } } 40 | 41 | 'functor'{ Keyword Kfunctor $$ } 42 | 'sig' { Keyword Ksig $$ } 43 | 'struct' { Keyword Kstruct $$ } 44 | 'module' { Keyword Kmodule $$ } 45 | 'where' { Keyword Kwhere $$ } 46 | 'type' { Keyword Ktype $$ } 47 | 'data' { Keyword Kdata $$ } 48 | 49 | 'require'{ Keyword Krequire $$ } 50 | 'open' { Keyword Kopen $$ } 51 | 'forall' { Keyword Kforall $$ } 52 | 53 | '|' { Keyword Kpipe $$ } 54 | 55 | '.' { Keyword Kdot $$ } 56 | ',' { Keyword Kcomma $$ } 57 | 58 | ':' { Keyword Kcolon $$ } 59 | '=' { Keyword Kassign $$ } 60 | 61 | 'let' { Keyword Klet $$ } 62 | 'in' { Keyword Kin $$ } 63 | 64 | 'case' { Keyword Kcase $$ } 65 | 'of' { Keyword Kof $$ } 66 | 67 | '\\' { Keyword Klambda $$ } 68 | '->' { Keyword Krarrow $$ } 69 | 70 | '_' { Keyword Kwild $$ } 71 | 72 | '(' { Keyword Klparen $$ } 73 | ')' { Keyword Krparen $$ } 74 | 75 | 'v{' { Lexeme { lexemeToken = TStart, lexemeRange = $$ } } 76 | 'v;' { Lexeme { lexemeToken = TSep, lexemeRange = $$ } } 77 | 'v}' { Lexeme { lexemeToken = TEnd, lexemeRange = $$ } } 78 | 79 | 80 | %monad { Dang } 81 | %error { parseError } 82 | 83 | %name top_module 84 | 85 | %% 86 | 87 | 88 | -- Top-level Module ------------------------------------------------------------ 89 | 90 | top_module :: { Module Parsed } 91 | : 'module' mod_name 'where' 'v{' top_decls 'v}' 92 | { Module { modMeta = $1 <-> $6 93 | , modName = $2 94 | , modRequires = fst $5 95 | , modDecls = snd $5 } } 96 | 97 | top_decls :: { ([Require Parsed],[Decl Parsed]) } 98 | : {- empty -} { ([], []) } 99 | | sep1('v;', require) { ($1, []) } 100 | | sep1('v;', require) 'v;' sep1('v;', decl) { ($1, concat $3) } 101 | | sep1('v;', decl) { ([], concat $1) } 102 | 103 | 104 | -- Require Statements ---------------------------------------------------------- 105 | 106 | require :: { Require Parsed } 107 | : 'require' mod_name { Require ($1 <-> $2) $2 False } 108 | | 'require' 'open' mod_name { Require ($1 <-> $3) $3 True } 109 | 110 | 111 | -- Declarations ---------------------------------------------------------------- 112 | 113 | decl :: { [Decl Parsed] } 114 | : signature { [ DSig (range sig) sig | sig <- $1 ] } 115 | | bind { [DBind (range $1) $1] } 116 | | data_decl { [DData (range $1) $1] } 117 | | type_synonym { [DSyn (range $1) $1] } 118 | | mod_bind { [$1] } 119 | | mod_type_bind { [$1] } 120 | 121 | 122 | -- Module Types ---------------------------------------------------------------- 123 | 124 | mod_type_bind :: { Decl Parsed } 125 | : 'module' 'type' con '=' mod_type 126 | { DModType ($1 <-> $5) $3 $5 } 127 | 128 | mod_type :: { ModType Parsed } 129 | : con 130 | { MTVar (range $1) $1 } 131 | 132 | | 'sig' layout(mod_spec) 133 | { let ds = concat $2 in 134 | MTSig ($1 <-> listLoc ds) ds } 135 | 136 | | 'functor' list1(mod_param) '->' mod_type 137 | { let { mk (p,ty) r = MTFunctor (p <-> r) p ty r 138 | } in foldr mk $4 $2 } 139 | 140 | mod_spec :: { [ModSpec Parsed] } 141 | : signature 142 | { [ MSSig (range sig) sig | sig <- $1 ] } 143 | 144 | | kind_sig 145 | { [ MSKind (range $1) $1 ] } 146 | 147 | | data_decl 148 | { [MSData (range $1) $1] } 149 | 150 | | 'module' mod_name ':' mod_type 151 | { [MSMod ($1 <-> $4) $2 $4] } 152 | 153 | 154 | -- Module Expressions ---------------------------------------------------------- 155 | 156 | mod_bind :: { Decl Parsed } 157 | : 'module' mod_name list(mod_param) opt(mod_restrict) '=' mod_expr 158 | { DModBind ($1 <-> $6) $2 (mkFunctor $3 (restrictMod $4 $6)) } 159 | 160 | mod_param :: { (SourceRange,IdentOf Parsed, ModType Parsed) } 161 | : '(' con ':' mod_type ')' 162 | { ($1 <-> $5, $2,$4) } 163 | 164 | mod_restrict :: { ModType Parsed } 165 | : ':' mod_type { $2 } 166 | 167 | mod_expr :: { ModExpr Parsed } 168 | : mod_bexpr opt(mod_constraint) 169 | { case $2 of 170 | Nothing -> $1 171 | Just ty -> MEConstraint ($1 <-> ty) $1 ty } 172 | 173 | mod_constraint :: { ModType Parsed } 174 | : ':' mod_type { $2 } 175 | 176 | mod_bexpr :: { ModExpr Parsed } 177 | : list1(mod_aexpr) 178 | { foldl1 (\ e x -> MEApp (e <-> x) e x) $1 } 179 | 180 | | mod_struct 181 | { MEStruct (range $1) $1 } 182 | 183 | mod_aexpr :: { ModExpr Parsed } 184 | : con { MEName (range $1) $1 } 185 | | qual_con { MEName (range $1) $1 } 186 | | '(' mod_expr ')' { $2 } 187 | 188 | mod_struct :: { ModStruct Parsed } 189 | : 'struct' 'v{' sep('v;', decl) 'v}' 190 | { ModStruct ($1 <-> $4) (concat $3) } 191 | 192 | 193 | -- Types ----------------------------------------------------------------------- 194 | 195 | kind_sig :: { Sig Parsed } 196 | : 'type' con ':' schema 197 | { Sig { sigMeta = $1 <-> $4 198 | , sigName = $2 199 | , sigSchema = $4 200 | } } 201 | 202 | signature :: { [Sig Parsed] } 203 | : sep1(',', ident) ':' schema 204 | { let { schemaLoc = range $3 205 | } in [ Sig { sigMeta = range sig <-> schemaLoc 206 | , sigName = sig 207 | , sigSchema = $3 208 | } | sig <- $1 ] } 209 | 210 | schema :: { Schema Parsed } 211 | : 'forall' list1(ident) '.' type { Schema ($1 <-> $4) $2 $4 } 212 | | type { Schema (range $1) [] $1 } 213 | 214 | type :: { Type Parsed } 215 | : sep1('->', app_type) { mkTFun $1 } 216 | 217 | app_type :: { Type Parsed } 218 | : list1(atype) { mkTApp $1 } 219 | 220 | atype :: { Type Parsed } 221 | : ident { TVar (range $1) $1 } 222 | | con { TCon (range $1) $1 } 223 | | qual_con { TCon (range $1) $1 } 224 | | '(' type ')' { $2 } 225 | 226 | 227 | -- Expressions ----------------------------------------------------------------- 228 | 229 | bind :: { Bind Parsed } 230 | : ident list(arg_pat) '=' expr 231 | { Bind { bMeta = $1 <-> $4 232 | , bName = $1 233 | , bSig = Nothing 234 | , bParams = $2 235 | , bBody = $4 } } 236 | 237 | arg_pat :: { Pat Parsed } 238 | : '_' { PWild $1 } 239 | | ident { PVar (range $1) $1 } 240 | | expr_con { PCon (range $1) $1 [] } 241 | | '(' con list(arg_pat) ')' { PCon ($1 <-> $4) $2 $3 } 242 | 243 | pat :: { Pat Parsed } 244 | : '_' { PWild $1 } 245 | | ident { PVar (range $1) $1 } 246 | | expr_con list(arg_pat) { PCon ($1 <-?> listLocMb $2) $1 $2 } 247 | 248 | expr :: { Expr Parsed } 249 | : list1(aexpr) 250 | { mkEApp $1 } 251 | 252 | | '\\' list1(arg_pat) '->' expr 253 | { EAbs ($1 <-> $4) $2 $4 } 254 | 255 | | 'let' layout(let_decl) 'in' expr 256 | { ELet ($1 <-> $4) (concat $2) $4 } 257 | 258 | | 'case' expr 'of' layout(case_arm) 259 | { ECase ($1 <-> listLoc $4) $2 (mkCases $4) } 260 | 261 | let_decl :: { [LetDecl Parsed] } 262 | : bind { [LDBind (range $1) $1] } 263 | | signature { [LDSig (range sig) sig | sig <- $1 ] } 264 | 265 | aexpr :: { Expr Parsed } 266 | : ident { EVar (range $1) $1 } 267 | | qual_ident { EVar (range $1) $1 } 268 | | expr_con { ECon (range $1) $1 } 269 | | lit { ELit (range $1) $1 } 270 | | '(' expr ')' { $2 } 271 | 272 | lit :: { Literal Parsed } 273 | : NUM { case $1 of 274 | NumLit base val range -> LInt range val base 275 | } 276 | 277 | 278 | case_arm :: { Match Parsed } 279 | : pat '->' expr 280 | { MPat ($1 <-> $3) $1 (MExpr (range $3) $3) } 281 | 282 | 283 | -- Data Declarations ----------------------------------------------------------- 284 | 285 | data_decl :: { Data Parsed } 286 | : 'data' con list(ident) opt(data_constrs) 287 | { Data { dMeta = $1 <-> $2 <-?> listLocMb $3 <-?> fmap listLoc $4 288 | , dName = $2 289 | , dParams = $3 290 | , dConstrs = fromMaybe [] $4 } } 291 | 292 | data_constrs :: { [Constr Parsed] } 293 | : '=' sep1('|', data_constr) { $2 } 294 | 295 | data_constr :: { Constr Parsed } 296 | : con list(atype) 297 | { Constr { cMeta = $1 <-> listRange $2 298 | , cName = $1 299 | , cParams = $2 } } 300 | 301 | type_synonym :: { Syn Parsed } 302 | : 'type' con list(ident) '=' type 303 | { Syn { synMeta = $1 <-> $5 304 | , synName = $2 305 | , synParams = $3 306 | , synType = $5 } } 307 | 308 | 309 | -- Names ----------------------------------------------------------------------- 310 | 311 | mod_name :: { IdentOf Parsed } 312 | : QUAL_CON 313 | { case $1 of 314 | Lexeme { lexemeToken = TQualCon ns n, .. } -> PQual lexemeRange ns n } 315 | 316 | | CON 317 | { case $1 of 318 | Lexeme { lexemeToken = TUnqualCon n, .. } -> PUnqual lexemeRange n } 319 | 320 | con :: { IdentOf Parsed } 321 | : CON 322 | { case $1 of 323 | Lexeme { lexemeToken = TUnqualCon n, .. } -> PUnqual lexemeRange n } 324 | 325 | qual_con :: { IdentOf Parsed } 326 | : QUAL_CON 327 | { case $1 of 328 | Lexeme { lexemeToken = TQualCon ns n, .. } -> PQual lexemeRange ns n } 329 | 330 | -- A constructor that can show up in a pattern or expression. 331 | expr_con :: { IdentOf Parsed } 332 | : con { $1 } 333 | | qual_con { $1 } 334 | 335 | qual_ident :: { IdentOf Parsed } 336 | : QUAL 337 | { case $1 of 338 | Lexeme { lexemeToken = TQualIdent ns n, .. } -> PQual lexemeRange ns n } 339 | 340 | -- identifiers are unqualified parsed-names 341 | ident :: { IdentOf Parsed } 342 | : UNQUAL 343 | { case $1 of 344 | Lexeme { lexemeToken = TUnqualIdent n, .. } -> PUnqual lexemeRange n } 345 | 346 | 347 | -- Utilities ------------------------------------------------------------------- 348 | 349 | layout(p) :: { [p] } 350 | : 'v{' sep1('v;', p) 'v}' { $2 } 351 | 352 | opt(p) :: { Maybe p } 353 | : {- empty -} { Nothing } 354 | | p { Just $1 } 355 | 356 | sep(p,q) :: { [q] } 357 | : {- empty -} { [] } 358 | | sep_body(p,q) { reverse $1 } 359 | 360 | sep1(p,q) :: { [q] } 361 | : sep_body(p,q) { reverse $1 } 362 | 363 | sep_body(p,q) :: { [q] } 364 | : q { [$1] } 365 | | sep_body(p,q) p q { $3 : $1 } 366 | 367 | list(p) :: { [p] } 368 | : {- empty -} { [] } 369 | | list_body(p) { reverse $1 } 370 | 371 | list1(p) :: { [p] } 372 | : list_body(p) { reverse $1 } 373 | 374 | list_body(p) :: { [p] } 375 | : p { [$1] } 376 | | list_body(p) p { $2 : $1 } 377 | 378 | 379 | -- External Interface ---------------------------------------------------------- 380 | 381 | { 382 | 383 | lexWithLayout :: Source -> Maybe SourcePos -> T.Text -> [Lexeme Token] 384 | lexWithLayout src mbStart txt = 385 | layout Layout { .. } (ignoreComments (lexer src mbStart txt)) 386 | where 387 | 388 | beginsLayout (TKeyword k) = k `elem` [Kwhere, Kstruct, Ksig, Klet, Kof] 389 | beginsLayout _ = False 390 | 391 | endsLayout (TKeyword Kin) = True 392 | endsLayout _ = False 393 | 394 | start = wrapToken TStart 395 | sep = wrapToken TSep 396 | end = wrapToken TEnd 397 | 398 | parseModule :: Source -> T.Text -> Dang PModule 399 | parseModule src txt = failErrors (top_module (lexWithLayout src Nothing txt)) 400 | 401 | 402 | -- Parser Monad ---------------------------------------------------------------- 403 | 404 | parseError :: [Lexeme Token] -> Dang a 405 | parseError toks = 406 | do case toks of 407 | loc : _ -> withLoc loc $ case lexemeToken loc of 408 | TError _ -> addError ErrLexer (text "Lexical error") 409 | _ -> addError ErrParser (text "Parse error") 410 | 411 | [] -> addError ErrParser (text "Unexpected end-of-file") 412 | 413 | mzero 414 | 415 | 416 | -- Utilities ------------------------------------------------------------------- 417 | 418 | pattern Keyword kw r <- Lexeme { lexemeToken = TKeyword kw, lexemeRange = r } 419 | 420 | pattern NumLit base n r <- Lexeme { lexemeToken = TNum base n, lexemeRange = r } 421 | 422 | mkTApp :: HasCallStack => [Type Parsed] -> Type Parsed 423 | mkTApp [t] = t 424 | mkTApp (t:ts) = TApp (t <-> last ts) t ts 425 | mkTApp _ = panic (text "mkTApp: empty list") 426 | 427 | mkTFun :: [Type Parsed] -> Type Parsed 428 | mkTFun = foldr1 $ \ty r -> TFun (ty <-> r) ty r 429 | 430 | mkEApp :: HasCallStack => [Expr Parsed] -> Expr Parsed 431 | mkEApp [e] = e 432 | mkEApp (e:es) = EApp (e <-> last es) e es 433 | mkEApp _ = panic (text "mkEApp: empty list") 434 | 435 | addParams :: [Pat Parsed] -> Expr Parsed -> Match Parsed 436 | addParams ps e = foldr step (MExpr (range e) e) ps 437 | where 438 | step p r = MPat (p <-> r) p r 439 | 440 | mkFunctor :: 441 | [(SourceRange,IdentOf Parsed, ModType Parsed)] 442 | -> ModExpr Parsed 443 | -> ModExpr Parsed 444 | mkFunctor [] e = e 445 | mkFunctor ps e = foldr step e ps 446 | where 447 | step (r,p,ty) body = MEFunctor (r <-> body) p ty body 448 | 449 | mkCases :: [Match Parsed] -> Match Parsed 450 | mkCases = foldr1 $ \ m acc -> MSplit (range acc) m acc 451 | 452 | restrictMod :: Maybe (ModType Parsed) -> ModExpr Parsed -> ModExpr Parsed 453 | restrictMod Nothing e = e 454 | restrictMod (Just ty) e = MEConstraint (e <-> ty) e ty 455 | 456 | listLoc :: (HasCallStack,HasRange a) => [a] -> SourceRange 457 | listLoc [] = error "listLoc: empty list" 458 | listLoc ls = range (last ls) 459 | 460 | listLocMb :: HasRange a => [a] -> Maybe SourceRange 461 | listLocMb [] = Nothing 462 | listLocMb ls = Just (range (last ls)) 463 | 464 | (<-?>) :: (HasRange a, HasRange b) => a -> Maybe b -> SourceRange 465 | r <-?> Just b = range r <-> b 466 | r <-?> _ = range r 467 | } 468 | -------------------------------------------------------------------------------- /src/Dang/Syntax/Signatures.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Dang.Syntax.Signatures ( 4 | resolveSignatures 5 | ) where 6 | 7 | 8 | import Dang.Monad 9 | import Dang.Syntax.AST 10 | import Dang.Utils.PP 11 | 12 | import qualified Data.Map.Strict as Map 13 | 14 | 15 | -- | Pair signatures with the declarations they describe. If any signatures 16 | -- mention declarations that don't exist, or occur after declarations, errors 17 | -- will be recorded and the pass will fail. 18 | resolveSignatures :: PModule -> Dang PModule 19 | resolveSignatures Module { .. } = failErrors $ 20 | do resolved <- resolveDecls modDecls 21 | return Module { modDecls = resolved, .. } 22 | 23 | 24 | -- Signature Resolution -------------------------------------------------------- 25 | 26 | type Resolve f = f Parsed -> Dang (f Parsed) 27 | 28 | type SigEnv = Map.Map PName (Sig Parsed) 29 | 30 | removeSig :: PName -> SigEnv -> Maybe (Sig Parsed, SigEnv) 31 | removeSig name env = 32 | case Map.updateLookupWithKey (\ _ _ -> Nothing) name env of 33 | (Just sig, env') -> Just (sig, env') 34 | _ -> Nothing 35 | 36 | -- | Associate signatures with bindings. Signatures may be placed before a 37 | -- declaration, but will not associate to declarations placed behind them. 38 | resolveDecls :: [Decl Parsed] -> Dang [Decl Parsed] 39 | resolveDecls = go [] Map.empty 40 | where 41 | 42 | -- no more declarations to process 43 | go acc sigs [] = 44 | do mapM_ sigWithoutBinding sigs 45 | return (reverse acc) 46 | 47 | -- add a signature to the signatures environment 48 | go acc sigs (DSig _ sig : ds) = 49 | go acc (Map.insert (sigName sig) sig sigs) ds 50 | 51 | -- for bindings, check to see if there's a signature to consume 52 | go acc sigs (DBind loc b : ds) = 53 | do b' <- resolveBind b 54 | case removeSig (bName b) sigs of 55 | Just (sig, sigs') -> 56 | go (DBind loc b' { bSig = Just (sigSchema sig) } : acc) sigs' ds 57 | 58 | Nothing -> 59 | go (DBind loc b' : acc) sigs ds 60 | 61 | 62 | -- recurse into module bindings 63 | go acc sigs (DModBind loc n mb : ds) = 64 | do mb' <- resolveModExpr mb 65 | go (DModBind loc n mb' : acc) sigs ds 66 | 67 | -- pass everything else through 68 | go acc sigs (d : ds) = 69 | go (d:acc) sigs ds 70 | 71 | 72 | -- | Resolve signatures within a block of let declarations. This functions the 73 | -- same as for normal declarations, but only has the value binding and signature 74 | -- cases. 75 | resolveLetDecls :: [LetDecl Parsed] -> Dang [LetDecl Parsed] 76 | resolveLetDecls = go [] Map.empty 77 | where 78 | go acc _ [] = 79 | return (reverse acc) 80 | 81 | go acc sigs (LDBind loc b : ds) = 82 | do b' <- resolveBind b 83 | case removeSig (bName b) sigs of 84 | Just (sig, sigs') -> 85 | go (LDBind loc b { bSig = Just (sigSchema sig) } : acc) sigs' ds 86 | 87 | Nothing -> 88 | go (LDBind loc b' : acc) sigs ds 89 | 90 | go acc sigs (LDSig _ sig : ds) = 91 | go acc (Map.insert (sigName sig) sig sigs) ds 92 | 93 | 94 | -- | Resolve signatures that occur within the body of a declaration. 95 | resolveBind :: Resolve Bind 96 | resolveBind Bind { .. } = withLoc bMeta $ 97 | do body' <- resolveExpr bBody 98 | return Bind { bBody = body', .. } 99 | 100 | 101 | -- | Resolve signatures within an expression. 102 | resolveExpr :: Resolve Expr 103 | 104 | resolveExpr e@EVar{} = 105 | return e 106 | 107 | resolveExpr e@ECon{} = 108 | return e 109 | 110 | resolveExpr e@ELit{} = 111 | return e 112 | 113 | resolveExpr (EApp loc f xs) = withLoc loc $ 114 | EApp loc <$> resolveExpr f <*> traverse resolveExpr xs 115 | 116 | resolveExpr (EAbs loc xs b) = withLoc loc $ 117 | EAbs loc xs <$> resolveExpr b 118 | 119 | resolveExpr (ELet loc ds e) = withLoc loc $ 120 | ELet loc <$> resolveLetDecls ds <*> resolveExpr e 121 | 122 | resolveExpr (ECase loc e body) = withLoc loc $ 123 | ECase loc <$> resolveExpr e <*> resolveMatch body 124 | 125 | 126 | -- | Resolve signatures within a matching expression. 127 | resolveMatch :: Resolve Match 128 | resolveMatch (MPat loc pat body) = withLoc loc $ 129 | MPat loc pat <$> resolveMatch body 130 | 131 | resolveMatch (MSplit loc l r) = withLoc loc $ 132 | MSplit loc <$> resolveMatch l <*> resolveMatch r 133 | 134 | resolveMatch m@MFail{} = 135 | return m 136 | 137 | resolveMatch (MExpr loc body) = withLoc loc $ 138 | MExpr loc <$> resolveExpr body 139 | 140 | 141 | -- | Resolve signatures within a module expression. 142 | resolveModExpr :: Resolve ModExpr 143 | 144 | resolveModExpr me@MEName{} = 145 | return me 146 | 147 | resolveModExpr (MEApp loc f x) = withLoc loc $ 148 | MEApp loc <$> resolveModExpr f <*> resolveModExpr x 149 | 150 | resolveModExpr (MEStruct loc ms) = withLoc loc $ 151 | MEStruct loc <$> resolveModStruct ms 152 | 153 | resolveModExpr (MEFunctor loc var ty e) = withLoc loc $ 154 | MEFunctor loc var ty <$> resolveModExpr e 155 | 156 | resolveModExpr (MEConstraint loc e ty) = withLoc loc $ 157 | MEConstraint loc <$> resolveModExpr e <*> return ty 158 | 159 | 160 | -- | Resolve signatures within a struct. 161 | resolveModStruct :: Resolve ModStruct 162 | resolveModStruct ModStruct { .. } = withLoc msMeta $ 163 | ModStruct msMeta <$> resolveDecls msElems 164 | 165 | 166 | -- Errors ---------------------------------------------------------------------- 167 | 168 | -- | Record errors for signatures that lack bindings. 169 | sigWithoutBinding :: Sig Parsed -> Dang () 170 | sigWithoutBinding Sig { .. } = 171 | withLoc sigMeta $ 172 | addError ErrNoDeclForSig $ 173 | text "Missing value binding for signature" <+> quotes (pp sigName) 174 | -------------------------------------------------------------------------------- /src/Dang/TypeCheck/AST.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | -- this is for the pass through of the MetaOf instance for Checked 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | module Dang.TypeCheck.AST where 9 | 10 | import Dang.AST 11 | import Dang.ModuleSystem.Name 12 | import Dang.Syntax.Location 13 | import Dang.Utils.PP 14 | 15 | import GHC.Generics (Generic) 16 | 17 | 18 | newtype TVar = TVar { tvName :: Name 19 | } deriving (Eq,Ord,Show,Generic) 20 | 21 | data Schema = Forall [TVar] Type 22 | deriving (Eq,Ord,Show,Generic) 23 | 24 | data Type = TFree !TVar 25 | | TGen !TVar 26 | | TCon !Name 27 | | TApp !Type !Type 28 | | TFun !Type !Type 29 | deriving (Eq,Ord,Show,Generic) 30 | 31 | data BindMeta = BindMeta !SourceRange Schema 32 | deriving (Show) 33 | 34 | instance HasRange BindMeta where 35 | range (BindMeta l _) = l 36 | {-# INLINE range #-} 37 | 38 | 39 | -- AST ------------------------------------------------------------------------- 40 | 41 | data Checked 42 | 43 | type instance IdentOf Checked = Name 44 | type instance TypeOf Checked = Type 45 | type instance SchemaOf Checked = Schema 46 | type instance MetaOf Checked = SourceRange 47 | 48 | 49 | -- Pretty-printing ------------------------------------------------------------- 50 | 51 | instance PP TVar where 52 | ppr (TVar n) = pp n 53 | 54 | instance PP Type where 55 | ppr (TFree v) = char '?' <> ppr v 56 | ppr (TGen v) = ppr v 57 | ppr (TCon n) = ppr n 58 | ppr (TApp f x) = optParens 10 (hang (pp f) 2 (ppPrec 10 x)) 59 | ppr (TFun a b) = optParens 10 (hang (ppPrec 10 a) 2 60 | (text "->" <+> pp b)) 61 | -------------------------------------------------------------------------------- /src/Dang/TypeCheck/Env.hs: -------------------------------------------------------------------------------- 1 | module Dang.TypeCheck.Env where 2 | -------------------------------------------------------------------------------- /src/Dang/TypeCheck/KindCheck.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Dang.TypeCheck.KindCheck (checkModule) where 4 | 5 | import Dang.ModuleSystem.Name (Name) 6 | import Dang.ModuleSystem.Rename (Renamed) 7 | import Dang.Monad 8 | import Dang.Syntax.AST 9 | import Dang.TypeCheck.AST as TC 10 | import Dang.TypeCheck.Monad 11 | import Dang.Utils.Panic 12 | 13 | import Data.List (partition) 14 | 15 | 16 | checkModule :: HasCallStack => Module Renamed -> Dang (Module Checked) 17 | checkModule m = runTC (kcModule m) 18 | 19 | 20 | -- Checking -------------------------------------------------------------------- 21 | 22 | type KindCheck f = f Renamed -> TC (f Checked) 23 | 24 | kcModule :: HasCallStack => KindCheck Module 25 | kcModule Module { .. } = withLoc modMeta $ 26 | do decls' <- kcStructDecls modDecls 27 | return Module { modDecls = decls' 28 | , modRequires = [] -- XXX: fix this 29 | , .. } 30 | 31 | kcStructDecls :: HasCallStack => [Decl Renamed] -> TC [Decl Checked] 32 | kcStructDecls ds = 33 | do let (sigs,rest) = partition isSig ds 34 | 35 | panic ("not done" ++ show sigs) 36 | -------------------------------------------------------------------------------- /src/Dang/TypeCheck/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Dang.TypeCheck.Monad ( 6 | TC(), runTC, 7 | Subst.Unify, unify, 8 | Subst.Zonk, zonk, ftvs, 9 | ) where 10 | 11 | import Dang.Monad (Dang) 12 | import Dang.TypeCheck.AST (TVar) 13 | import qualified Dang.TypeCheck.Subst as Subst 14 | 15 | import Control.Applicative (Alternative(..)) 16 | import Control.Monad (MonadPlus(..)) 17 | import qualified Data.Set as Set 18 | import MonadLib (BaseM(..),StateT,get,set,runM) 19 | 20 | data RW = RW { rwSubst :: !Subst.Subst 21 | } 22 | 23 | newtype TC a = TC { unTC :: StateT RW Dang a 24 | } deriving (Functor,Applicative,Monad) 25 | 26 | runTC :: TC a -> Dang a 27 | runTC (TC m) = fst `fmap` runM m RW { rwSubst = Subst.emptySubst } 28 | 29 | instance BaseM TC Dang where 30 | inBase m = TC (inBase m) 31 | {-# INLINE inBase #-} 32 | 33 | instance Alternative TC where 34 | empty = TC empty 35 | a <|> b = TC (unTC a <|> unTC b) 36 | {-# INLINE empty #-} 37 | {-# INLINE (<|>) #-} 38 | 39 | instance MonadPlus TC where 40 | mzero = TC mzero 41 | mplus a b = TC (unTC a `mplus` unTC b) 42 | {-# INLINE mzero #-} 43 | {-# INLINE mplus #-} 44 | 45 | -- | Unify two things that have types, and update the internal state. 46 | unify :: Subst.Unify a => a -> a -> TC () 47 | unify a b = TC $ 48 | do RW { .. } <- get 49 | su' <- Subst.unify rwSubst a b 50 | set $! RW { rwSubst = su' } 51 | 52 | -- | Remove type variables from a thing that has types. 53 | -- 54 | -- NOTE: this will fail if the type given is infinite. 55 | zonk :: Subst.Zonk a => a -> TC a 56 | zonk a = TC $ 57 | do RW { .. } <- get 58 | Subst.zonk rwSubst a 59 | 60 | -- | Calculate the free variables of a thing that has types. 61 | -- 62 | -- NOTE: this will fail with if the type given is infinite. 63 | ftvs :: Subst.Zonk a => a -> TC (Set.Set TVar) 64 | ftvs a = TC $ 65 | do RW { .. } <- get 66 | Subst.ftvs rwSubst a 67 | -------------------------------------------------------------------------------- /src/Dang/TypeCheck/Subst.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE DefaultSignatures #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | 10 | module Dang.TypeCheck.Subst ( 11 | Subst(), emptySubst, modifySkolems, 12 | Zonk(), zonk, ftvs, 13 | Unify(), unify, 14 | ) where 15 | 16 | import Dang.ModuleSystem.Name (mkBinding,mkParam,ParamSource(..)) 17 | import Dang.Monad 18 | import Dang.TypeCheck.AST (TVar(..),Type(..)) 19 | import Dang.Utils.PP 20 | import Dang.Unique (withSupply) 21 | import Dang.Syntax.Format (formatMessage) 22 | import Dang.Syntax.Location (Source(..),interactive,emptyRange) 23 | 24 | import Control.Monad (mzero,unless) 25 | import qualified Data.Set as Set 26 | import qualified Data.IntMap.Strict as IM 27 | import qualified Data.Map.Strict as Map 28 | import GHC.Generics 29 | import MonadLib (runStateT,StateT,get,set,inBase) 30 | 31 | 32 | -- Environment ----------------------------------------------------------------- 33 | 34 | data Subst = Subst { suCanon :: !(Map.Map TVar Int) 35 | -- ^ Canonical names for unification variables -- unifying 36 | -- two variables corresponds to manipulating this map only. 37 | 38 | , suEnv :: !(IM.IntMap Type) 39 | -- ^ Bindings to canonical names 40 | 41 | , suNext :: !Int 42 | -- ^ The next canonical name available. 43 | 44 | , suSkolems :: !(Set.Set TVar) 45 | -- ^ The set of Skolemized variables 46 | } 47 | 48 | emptySubst :: Subst 49 | emptySubst = Subst Map.empty IM.empty 0 Set.empty 50 | 51 | -- | Merge two variables in the substitution environment. 52 | merge :: TVar -> TVar -> Subst -> Maybe Subst 53 | merge a b Subst { .. } = 54 | case (Map.lookup a suCanon, Map.lookup b suCanon) of 55 | 56 | (Just{}, Just{}) -> Nothing 57 | 58 | (Just x, Nothing) -> 59 | Just Subst { suCanon = Map.insert b x suCanon, .. } 60 | 61 | (Nothing, Just x) -> 62 | Just Subst { suCanon = Map.insert a x suCanon, .. } 63 | 64 | (Nothing,Nothing) -> 65 | Just Subst { suCanon = Map.insert a suNext 66 | $ Map.insert b suNext suCanon 67 | , suNext = suNext + 1 68 | , .. } 69 | 70 | 71 | -- | Insert a type into the environment. 72 | insertType :: TVar -> Type -> Subst -> Subst 73 | insertType a ty Subst { .. } = 74 | case Map.lookup a suCanon of 75 | Just ix -> 76 | Subst { suEnv = IM.insert ix ty suEnv, .. } 77 | 78 | Nothing -> 79 | Subst { suCanon = Map.insert a suNext suCanon 80 | , suEnv = IM.insert suNext ty suEnv 81 | , suNext = suNext + 1 82 | , .. } 83 | 84 | 85 | -- | Modify the set of Skolem variables 86 | modifySkolems :: (Set.Set TVar -> Set.Set TVar) -> (Subst -> Subst) 87 | modifySkolems f Subst { .. } = Subst { suSkolems = f suSkolems, .. } 88 | 89 | 90 | -- Monad ----------------------------------------------------------------------- 91 | 92 | type M = StateT Subst Dang 93 | 94 | -- | Lookup the binding for a type variable, if it exists. 95 | lookupType :: TVar -> M (Maybe Type) 96 | lookupType var = 97 | do Subst { .. } <- get 98 | case Map.lookup var suCanon of 99 | Just i -> return (IM.lookup i suEnv) 100 | Nothing -> return Nothing 101 | 102 | -- | The two types failed to unify. 103 | unificationFailed :: (PP a, PP b) => a -> b -> M r 104 | unificationFailed expected found = 105 | do addError ErrUnification $ 106 | vcat [ hang (text "Expected type:") 2 (pp expected) 107 | , hang (text " Found type:") 2 (pp found) ] 108 | mzero 109 | 110 | occursCheckFailed :: TVar -> Type -> M a 111 | occursCheckFailed var ty = 112 | do addError ErrInfiniteType $ 113 | hang (text "Cannot construct the infinite type:") 114 | 2 (pp (TFree var) <+> char '~' <+> pp ty) 115 | mzero 116 | 117 | 118 | -- Zonking --------------------------------------------------------------------- 119 | 120 | -- | Remove type variables from a type. 121 | zonk :: (Zonk a, DangM m) => Subst -> a -> m a 122 | zonk su a = inBase (fst `fmap` runStateT su (zonk' Set.empty a)) 123 | 124 | ftvs :: (Zonk a, DangM m) => Subst -> a -> m (Set.Set TVar) 125 | ftvs su a = inBase (fst `fmap` runStateT su (ftvs' Set.empty a)) 126 | 127 | class Zonk a where 128 | zonk' :: Set.Set TVar -> a -> M a 129 | ftvs' :: Set.Set TVar -> a -> M (Set.Set TVar) 130 | 131 | default zonk' :: (Generic a, GZonk (Rep a)) => Set.Set TVar -> a -> M a 132 | zonk' seen a = to `fmap` gzonk' seen (from a) 133 | 134 | default ftvs' :: (Generic a, GZonk (Rep a)) => Set.Set TVar -> a -> M (Set.Set TVar) 135 | ftvs' seen a = gftvs' seen (from a) 136 | 137 | 138 | instance Zonk () 139 | instance Zonk a => Zonk (Maybe a) 140 | instance Zonk a => Zonk [a] 141 | 142 | 143 | resolve :: Set.Set TVar -> TVar -> M (Maybe (Set.Set TVar,Type)) 144 | resolve seen v = 145 | do Subst { .. } <- get 146 | case Map.lookup v suCanon of 147 | Just i -> 148 | case IM.lookup i suEnv of 149 | Just ty' | v `Set.member` seen -> occursCheckFailed v ty' 150 | | otherwise -> return (Just (Set.insert v seen,ty')) 151 | 152 | Nothing -> return Nothing 153 | 154 | Nothing -> return Nothing 155 | 156 | instance Zonk Type where 157 | zonk' seen ty@(TFree v) = 158 | do mb <- resolve seen v 159 | case mb of 160 | Just (seen',ty') -> zonk' seen' ty' 161 | Nothing -> return ty 162 | 163 | zonk' _ ty@TGen{} = 164 | return ty 165 | 166 | zonk' _ ty@TCon{} = 167 | return ty 168 | 169 | zonk' seen (TApp f x) = 170 | do f' <- zonk' seen f 171 | x' <- zonk' seen x 172 | return (TApp f' x') 173 | 174 | zonk' seen (TFun a b) = 175 | do a' <- zonk' seen a 176 | b' <- zonk' seen b 177 | return (TFun a' b') 178 | 179 | 180 | ftvs' seen (TFree v) = 181 | do mb <- resolve seen v 182 | case mb of 183 | Just (seen', ty') -> ftvs' seen' ty' 184 | Nothing -> return Set.empty 185 | 186 | ftvs' _ TGen{} = 187 | return Set.empty 188 | 189 | ftvs' _ TCon{} = 190 | return Set.empty 191 | 192 | ftvs' seen (TApp a b) = 193 | do as <- ftvs' seen a 194 | bs <- ftvs' seen b 195 | return (as `Set.union` bs) 196 | 197 | ftvs' seen (TFun a b) = 198 | do as <- ftvs' seen a 199 | bs <- ftvs' seen b 200 | return (as `Set.union` bs) 201 | 202 | 203 | class GZonk (f :: * -> *) where 204 | gzonk' :: Set.Set TVar -> f a -> M (f a) 205 | gftvs' :: Set.Set TVar -> f a -> M (Set.Set TVar) 206 | 207 | instance GZonk U1 where 208 | gzonk' _ u = return u 209 | gftvs' _ _ = return Set.empty 210 | 211 | instance Zonk a => GZonk (K1 i a) where 212 | gzonk' seen (K1 a) = K1 `fmap` zonk' seen a 213 | gftvs' seen (K1 a) = ftvs' seen a 214 | 215 | instance GZonk f => GZonk (M1 i c f) where 216 | gzonk' seen (M1 f) = M1 `fmap` gzonk' seen f 217 | gftvs' seen (M1 f) = gftvs' seen f 218 | 219 | instance (GZonk f, GZonk g) => GZonk (f :+: g) where 220 | gzonk' seen (L1 f) = L1 `fmap` gzonk' seen f 221 | gzonk' seen (R1 g) = R1 `fmap` gzonk' seen g 222 | 223 | gftvs' seen (L1 f) = gftvs' seen f 224 | gftvs' seen (R1 g) = gftvs' seen g 225 | 226 | instance (GZonk f, GZonk g) => GZonk (f :*: g) where 227 | gzonk' seen (f :*: g) = 228 | do f' <- gzonk' seen f 229 | g' <- gzonk' seen g 230 | return (f' :*: g') 231 | 232 | gftvs' seen (f :*: g) = 233 | do fs <- gftvs' seen f 234 | gs <- gftvs' seen g 235 | return (fs `Set.union` gs) 236 | 237 | 238 | -- Unification ----------------------------------------------------------------- 239 | 240 | unify :: (Unify a, DangM m) => Subst -> a -> a -> m Subst 241 | unify su a b = inBase (snd `fmap` runStateT su (unify' a b)) 242 | 243 | class (PP a, Zonk a) => Unify a where 244 | unify' :: a -> a -> M () 245 | 246 | default unify' :: (Generic a, GUnify (Rep a)) => a -> a -> M () 247 | unify' a b = 248 | do success <- gunify' (from a) (from b) 249 | unless success (unificationFailed a b) 250 | 251 | instance (PP a, Unify a) => Unify (Maybe a) 252 | instance (PP a, Unify a) => Unify [a] 253 | 254 | instance Unify Type where 255 | unify' (TFree a) ty = 256 | do mb <- lookupType a 257 | case mb of 258 | Just ty' -> unify' ty' ty 259 | Nothing -> bindVar a ty 260 | 261 | unify' ty (TFree a) = 262 | do mb <- lookupType a 263 | case mb of 264 | Just ty' -> unify' ty ty' 265 | Nothing -> bindVar a ty 266 | 267 | unify' (TCon a) (TCon b) | a == b = return () 268 | 269 | unify' (TGen a) (TGen b) | a == b = return () 270 | 271 | unify' (TApp a b) (TApp x y) = 272 | do unify' a x 273 | unify' b y 274 | 275 | unify' (TFun a b) (TFun x y) = 276 | do unify' a x 277 | unify' b y 278 | 279 | unify' a b = unificationFailed a b 280 | 281 | class GZonk f => GUnify f where 282 | gunify' :: f a -> f b -> M Bool 283 | 284 | instance GUnify U1 where 285 | gunify' U1 U1 = return True 286 | 287 | instance Unify a => GUnify (K1 i a) where 288 | gunify' (K1 a) (K1 b) = 289 | do unify' a b 290 | return True 291 | 292 | instance GUnify f => GUnify (M1 i c f) where 293 | gunify' (M1 a) (M1 b) = gunify' a b 294 | 295 | instance (GUnify f, GUnify g) => GUnify (f :+: g) where 296 | gunify' (L1 a) (L1 b) = gunify' a b 297 | gunify' (R1 a) (R1 b) = gunify' a b 298 | gunify' _ _ = return False 299 | 300 | instance (GUnify f, GUnify g) => GUnify (f :*: g) where 301 | gunify' (x :*: y) (a :*: b) = 302 | do r <- gunify' x a 303 | if r then gunify' y b 304 | else return r 305 | 306 | bindVar :: TVar -> Type -> M () 307 | bindVar var ty 308 | -- trivial case of a unification variable unifying with itself 309 | | TFree var == ty = return () 310 | 311 | -- XXX should do kind checking as well 312 | 313 | -- merge variables 314 | | TFree var' <- ty = 315 | do su <- get 316 | case merge var var' su of 317 | Just su' -> set $! su' 318 | Nothing -> unificationFailed (TFree var) ty 319 | 320 | -- allocate a fresh canonical name, and insert into the environment 321 | | otherwise = 322 | do su <- get 323 | set $! insertType var ty su 324 | 325 | 326 | test = runDang $ 327 | do cxt <- withSupply (mkBinding "Main" "cxt" emptyRange) 328 | fooC <- withSupply (mkBinding "Main" "Foo" emptyRange) 329 | a <- withSupply (mkParam (FromBind cxt) "a" emptyRange) 330 | b <- withSupply (mkParam (FromBind cxt) "b" emptyRange) 331 | su <- unify emptySubst (TFree (TVar a)) (TCon fooC) 332 | su' <- unify su (TFree (TVar a)) (TFree (TVar b)) 333 | 334 | fun <- zonk su' (TFun (TFree (TVar a)) (TFree (TVar b))) 335 | io (print (pp fun)) 336 | 337 | c <- withSupply (mkParam (FromBind cxt) "c" emptyRange) 338 | let var = TFree (TVar c) 339 | su'' <- unify su' var (TFun var var) 340 | 341 | (c',ms) <- collectMessages (try (zonk su'' var)) 342 | 343 | io (mapM_ (print . formatMessage interactive "") ms) 344 | io (print c') 345 | 346 | return () 347 | -------------------------------------------------------------------------------- /src/Dang/Unique.hs: -------------------------------------------------------------------------------- 1 | module Dang.Unique ( 2 | Supply(), SupplyM(..), 3 | initialSupply, 4 | nextUnique, 5 | 6 | Unique(), 7 | ) where 8 | 9 | import MonadLib (StateT, ExceptionT, lift) 10 | 11 | 12 | -- Unique Generation ----------------------------------------------------------- 13 | 14 | newtype Supply = Supply Int 15 | deriving (Show) 16 | 17 | initialSupply :: Supply 18 | initialSupply = Supply 0 19 | 20 | nextUnique :: Supply -> (Supply,Unique a) 21 | nextUnique (Supply i) = 22 | let s' = Supply (i + 1) 23 | in s' `seq` (s',Unique i) 24 | 25 | class SupplyM m where 26 | withSupply :: (Supply -> (Supply,a)) -> m a 27 | 28 | instance (Monad m, SupplyM m) => SupplyM (StateT i m) where 29 | withSupply f = lift (withSupply f) 30 | 31 | instance (Monad m, SupplyM m) => SupplyM (ExceptionT i m) where 32 | withSupply f = lift (withSupply f) 33 | 34 | 35 | -- Uniques --------------------------------------------------------------------- 36 | 37 | newtype Unique a = Unique Int 38 | deriving (Eq,Ord,Show) 39 | -------------------------------------------------------------------------------- /src/Dang/Utils/Ident.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Dang.Utils.Ident ( 4 | Namespace, 5 | packNamespace, 6 | packNamespaceLazy, 7 | 8 | Ident(), 9 | mkIdent, 10 | identText, 11 | 12 | dot, 13 | ) where 14 | 15 | import qualified Data.Text as S 16 | import qualified Data.Text.Lazy as L 17 | 18 | 19 | type Namespace = S.Text 20 | 21 | packNamespace :: [S.Text] -> Namespace 22 | packNamespace = S.intercalate "." 23 | 24 | packNamespaceLazy :: [L.Text] -> Namespace 25 | packNamespaceLazy ns = L.toStrict (L.intercalate "." ns) 26 | 27 | 28 | newtype Ident = Ident S.Text 29 | deriving (Show) 30 | 31 | mkIdent :: S.Text -> Ident 32 | mkIdent = Ident 33 | 34 | identText :: Ident -> S.Text 35 | identText (Ident t) = t 36 | 37 | dot :: Namespace -> Namespace -> Namespace 38 | dot l r = S.concat [l, ".", r] 39 | {-# INLINE dot #-} 40 | -------------------------------------------------------------------------------- /src/Dang/Utils/PP.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module Dang.Utils.PP ( 6 | -- * Config 7 | Config(..), defaultConfig, 8 | 9 | -- ** Name display 10 | NameDisp(), 11 | neverQualify, 12 | alwaysQualify, 13 | NameFormat(..), 14 | formatName, 15 | 16 | -- * Pretty-printer 17 | Doc(), 18 | printDoc, hPrintDoc, 19 | 20 | -- ** Annotations 21 | Ann(..), 22 | annotate, 23 | 24 | -- ** Names 25 | getNameFormat, 26 | 27 | -- ** Class 28 | PP(..), pretty, ppPrec, pp, 29 | 30 | -- ** Combinators 31 | (<>), (<+>), ($$), ($+$), 32 | fsep, sep, hsep, cat, vcat, hcat, punctuate, 33 | optParens, parens, brackets, angles, quotes, 34 | comma, commas, 35 | text, char, int, integer, 36 | hang, nest, 37 | emptyDoc, 38 | flow, 39 | ) where 40 | 41 | import Dang.Syntax.Location 42 | import Dang.Utils.Ident 43 | 44 | import Control.Monad (mplus) 45 | import Data.Int (Int64) 46 | import Data.String (IsString(..)) 47 | import qualified Data.Text as T 48 | import qualified Data.Text.Lazy as L 49 | import MonadLib (ReaderT,Id,runReaderT,runId,ask,local) 50 | import qualified System.Console.ANSI as Ansi 51 | import qualified System.Console.Terminal.Size as Term 52 | import System.IO (Handle,hPutStr,hPutChar,stdout) 53 | import qualified Text.PrettyPrint.Annotated.HughesPJ as PJ 54 | 55 | 56 | -- PP Config ------------------------------------------------------------------- 57 | 58 | data Config = Config { cfgNameDisp :: NameDisp 59 | } 60 | 61 | defaultConfig :: Config 62 | defaultConfig = Config { cfgNameDisp = mempty 63 | } 64 | 65 | 66 | -- Name Display ---------------------------------------------------------------- 67 | 68 | -- | How to display names, inspired by the GHC `Outputable` module. 69 | data NameDisp = EmptyNameDisp 70 | | NameDisp (Namespace -> Ident -> Maybe NameFormat) 71 | 72 | instance Monoid NameDisp where 73 | mempty = EmptyNameDisp 74 | 75 | mappend (NameDisp f) (NameDisp g) = NameDisp (\ns i -> f ns i `mplus` g ns i) 76 | mappend EmptyNameDisp b = b 77 | mappend a EmptyNameDisp = a 78 | 79 | neverQualify :: Namespace -> NameDisp 80 | neverQualify ns = NameDisp $ \ ns' _ -> 81 | if ns == ns' 82 | then return UnQualified 83 | else Nothing 84 | 85 | alwaysQualify :: Namespace -> NameDisp 86 | alwaysQualify ns = NameDisp $ \ ns' _ -> 87 | if ns == ns' 88 | then return (Qualified ns) 89 | else Nothing 90 | 91 | 92 | data NameFormat = UnQualified 93 | | Qualified !Namespace 94 | deriving (Show) 95 | 96 | -- | Lookup formatting information for a name. A result of 'Nothing' indicates 97 | -- that the name is not in scope. 98 | formatName :: NameDisp -> Namespace -> Ident -> Maybe NameFormat 99 | formatName EmptyNameDisp = \ _ _ -> Nothing 100 | formatName (NameDisp f) = f 101 | 102 | 103 | -- PP Environment -------------------------------------------------------------- 104 | 105 | data Env = Env { envConfig :: !Config 106 | , envPrec :: !Int 107 | } 108 | 109 | defaultEnv :: Config -> Env 110 | defaultEnv envConfig = Env { envPrec = 0, .. } 111 | 112 | getNameFormat :: Namespace -> Ident -> DocM (Maybe NameFormat) 113 | getNameFormat ns i = DocM $ 114 | do Env { .. } <- ask 115 | return $! formatName (cfgNameDisp envConfig) ns i 116 | 117 | 118 | -- Monad ----------------------------------------------------------------------- 119 | 120 | newtype DocM a = DocM { unDocM :: ReaderT Env Id a 121 | } deriving (Functor,Applicative,Monad) 122 | 123 | type Doc = DocM (PJ.Doc Ann) 124 | 125 | instance IsString (DocM (PJ.Doc Ann)) where 126 | fromString = text 127 | 128 | instance Show (DocM (PJ.Doc Ann)) where 129 | show doc = show (runDoc defaultConfig doc) 130 | 131 | runDoc :: Config -> Doc -> PJ.Doc Ann 132 | runDoc cfg d = runId (runReaderT (defaultEnv cfg) (unDocM d)) 133 | 134 | getEnv :: DocM Env 135 | getEnv = DocM ask 136 | 137 | withEnv :: Env -> DocM a -> DocM a 138 | withEnv env m = DocM (local env (unDocM m)) 139 | 140 | getPrec :: DocM Int 141 | getPrec = envPrec <$> getEnv 142 | 143 | withPrec :: Int -> DocM a -> DocM a 144 | withPrec p m = 145 | do env <- getEnv 146 | withEnv env { envPrec = p } m 147 | 148 | 149 | -- Annotations ----------------------------------------------------------------- 150 | 151 | data Ann = AnnKeyword 152 | | AnnPunc 153 | | AnnLiteral 154 | | AnnComment 155 | | AnnError 156 | | AnnWarning 157 | | AnnGutter 158 | deriving (Show) 159 | 160 | sgrFor :: Ann -> [Ansi.SGR] 161 | sgrFor AnnKeyword = [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Green] 162 | sgrFor AnnPunc = [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Yellow] 163 | sgrFor AnnLiteral = [Ansi.SetColor Ansi.Foreground Ansi.Vivid Ansi.Magenta] 164 | sgrFor AnnComment = [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Green] 165 | sgrFor AnnError = [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Red] 166 | sgrFor AnnWarning = [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.Yellow] 167 | sgrFor AnnGutter = [Ansi.SetColor Ansi.Foreground Ansi.Dull Ansi.White] 168 | 169 | printDoc :: Config -> Doc -> IO () 170 | printDoc = hPrintDoc stdout 171 | 172 | -- | Print the document out, formatted for the console. 173 | hPrintDoc :: Handle -> Config -> Doc -> IO () 174 | hPrintDoc h cfg doc = 175 | do mb <- Term.hSize h 176 | len <- case mb of 177 | Just Term.Window { .. } -> return width 178 | Nothing -> return 80 179 | 180 | useAnsi <- Ansi.hSupportsANSI h 181 | 182 | fst $ PJ.fullRenderAnn PJ.PageMode len 1.5 (format useAnsi) (return (),[]) 183 | $ runDoc cfg doc 184 | 185 | where 186 | 187 | format True PJ.AnnotStart (rest,stack) = (rest',drop 1 stack) 188 | where 189 | rest' = do Ansi.hSetSGR h [] 190 | Ansi.hSetSGR h (concat stack) 191 | rest 192 | 193 | format True (PJ.AnnotEnd ann) (rest,stack) = (rest', sgrFor ann : stack) 194 | where 195 | rest' = do Ansi.hSetSGR h [] 196 | rest 197 | 198 | format _ (PJ.NoAnnot td _) (rest,stack) = (fmt >> rest, stack) 199 | where 200 | fmt = case td of 201 | PJ.Chr c -> hPutChar h c 202 | PJ.Str s -> hPutStr h s 203 | PJ.PStr s -> hPutStr h s 204 | 205 | format False _ x = x 206 | 207 | annotate :: Ann -> Doc -> Doc 208 | annotate ann m = PJ.annotate ann <$> m 209 | 210 | 211 | -- Class ----------------------------------------------------------------------- 212 | 213 | pretty :: PP a => a -> String 214 | pretty a = PJ.render (runDoc defaultConfig (pp a)) 215 | 216 | ppPrec :: PP a => Int -> a -> Doc 217 | ppPrec p a = withPrec p (ppr a) 218 | 219 | pp :: PP a => a -> Doc 220 | pp = ppPrec 0 221 | 222 | 223 | class PP a where 224 | ppr :: a -> Doc 225 | pprList :: [a] -> Doc 226 | pprList as = brackets (fsep (commas (map pp as))) 227 | 228 | instance PP a => PP [a] where 229 | ppr = pprList 230 | 231 | instance PP a => PP (Maybe a) where 232 | ppr (Just a) = ppr a 233 | ppr Nothing = angles (text "nothing") 234 | 235 | instance PP (DocM (PJ.Doc Ann)) where 236 | ppr = id 237 | {-# INLINE ppr #-} 238 | 239 | instance PP Char where 240 | ppr = char 241 | pprList = text 242 | 243 | instance PP Integer where 244 | ppr = integer 245 | 246 | instance PP Int where 247 | ppr = int 248 | 249 | instance PP Int64 where 250 | ppr = ppr . toInteger 251 | 252 | instance PP T.Text where 253 | ppr s = text (T.unpack s) 254 | 255 | instance PP L.Text where 256 | ppr s = text (L.unpack s) 257 | 258 | instance PP Ident where 259 | ppr ident = ppr (identText ident) 260 | 261 | instance PP SourcePos where 262 | ppr pos = text (prettySourcePos pos) 263 | 264 | instance PP SourceRange where 265 | ppr pos = text (prettySourceRange pos) 266 | 267 | 268 | -- Combinators ----------------------------------------------------------------- 269 | 270 | liftDoc2 :: (PJ.Doc Ann -> PJ.Doc Ann -> PJ.Doc Ann) -> (Doc -> Doc -> Doc) 271 | liftDoc2 f a b = f <$> a <*> b 272 | 273 | (<>) :: Doc -> Doc -> Doc 274 | (<>) = liftDoc2 (PJ.<>) 275 | 276 | (<+>) :: Doc -> Doc -> Doc 277 | (<+>) = liftDoc2 (PJ.<+>) 278 | 279 | ($$) :: Doc -> Doc -> Doc 280 | ($$) = liftDoc2 (PJ.$$) 281 | 282 | ($+$) :: Doc -> Doc -> Doc 283 | ($+$) = liftDoc2 (PJ.$+$) 284 | 285 | fsep :: [Doc] -> Doc 286 | fsep ds = PJ.fsep <$> sequence ds 287 | 288 | flow :: String -> Doc 289 | flow = fsep . map text . words 290 | 291 | sep :: [Doc] -> Doc 292 | sep ds = PJ.sep <$> sequence ds 293 | 294 | hsep :: [Doc] -> Doc 295 | hsep ds = PJ.hsep <$> sequence ds 296 | 297 | vcat :: [Doc] -> Doc 298 | vcat ds = PJ.vcat <$> sequence ds 299 | 300 | cat :: [Doc] -> Doc 301 | cat ds = PJ.cat <$> sequence ds 302 | 303 | hcat :: [Doc] -> Doc 304 | hcat ds = PJ.hcat <$> sequence ds 305 | 306 | optParens :: Int -> Doc -> Doc 307 | optParens n doc = 308 | do p <- getPrec 309 | if p > n then parens doc 310 | else doc 311 | 312 | parens :: Doc -> Doc 313 | parens = fmap PJ.parens 314 | 315 | brackets :: Doc -> Doc 316 | brackets = fmap PJ.brackets 317 | 318 | angles :: Doc -> Doc 319 | angles d = char '<' <> d <> char '>' 320 | 321 | quotes :: Doc -> Doc 322 | quotes d = char '`' <> d <> char '`' 323 | 324 | punctuate :: Doc -> [Doc] -> [Doc] 325 | punctuate p xs = go xs 326 | where 327 | go [d] = [d] 328 | go (d:ds) = d <> p : go ds 329 | go [] = [] 330 | 331 | comma :: Doc 332 | comma = char ',' 333 | 334 | commas :: [Doc] -> [Doc] 335 | commas = punctuate comma 336 | 337 | text :: String -> Doc 338 | text s = return (PJ.text s) 339 | 340 | char :: Char -> Doc 341 | char c = return (PJ.char c) 342 | 343 | integer :: Integer -> Doc 344 | integer i = return (PJ.integer i) 345 | 346 | int :: Int -> Doc 347 | int i = return (PJ.int i) 348 | 349 | hang :: Doc -> Int -> Doc -> Doc 350 | hang a i b = PJ.hang <$> a <*> pure i <*> b 351 | 352 | nest :: Int -> Doc -> Doc 353 | nest i d = PJ.nest i <$> d 354 | 355 | emptyDoc :: Doc 356 | emptyDoc = return PJ.empty 357 | -------------------------------------------------------------------------------- /src/Dang/Utils/Panic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | module Dang.Utils.Panic ( 5 | panic, 6 | Panic(), 7 | HasCallStack, 8 | ) where 9 | 10 | import Dang.Utils.PP 11 | 12 | import qualified Control.Exception as X 13 | import Data.Typeable (Typeable) 14 | import GHC.Stack 15 | 16 | 17 | data Panic = Panic CallStack Doc 18 | deriving (Show,Typeable) 19 | 20 | instance X.Exception Panic 21 | 22 | instance PP Panic where 23 | ppr (Panic cxt msg) = 24 | vcat [ line "PANIC" 25 | , msg 26 | , text "" 27 | , hang (text "from") 2 (vcat (map ppCxt stack)) 28 | , line "PANIC" 29 | ] 30 | where 31 | stack = getCallStack cxt 32 | 33 | line str = 34 | let len = 80 - length str - 4 35 | in text "--" <+> text str <+> text (replicate len '-') 36 | 37 | ppCxt (fun,SrcLoc { .. }) = text srcLocModule 38 | <> char ':' 39 | <> ppr srcLocStartLine 40 | <> char ',' 41 | <> ppr srcLocStartCol 42 | <+> text fun 43 | 44 | 45 | panic :: (HasCallStack, PP msg) => msg -> a 46 | panic msg = 47 | let stack = freezeCallStack callStack 48 | in X.throw (Panic stack (pp msg)) 49 | --------------------------------------------------------------------------------