@ -1,2 +1,4 @@ | |||
import Distribution.Simple | |||
main = defaultMain |
@ -0,0 +1,37 @@ | |||
{-# LANGUAGE RankNTypes #-} | |||
module Ahc.Data.Lens where | |||
import Control.Applicative | |||
import Data.Functor.Identity | |||
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t | |||
type Lens' s a = Lens s s a a | |||
get :: Lens s t a b -> s -> a | |||
get l = getConst . l Const | |||
over :: Lens s t a b -> (a -> b) -> s -> t | |||
over l m = runIdentity . l (Identity . m) | |||
set :: Lens s t a b -> b -> s -> t | |||
set l b a = over l (const b) a | |||
(.~) :: Lens s t a b -> b -> s -> t | |||
(.~) = set | |||
infixr 4 .~ | |||
(%~) :: Lens s t a b -> (a -> b) -> s -> t | |||
(%~) = over | |||
infixr 4 %~ | |||
(^.) :: s -> Lens s t a b -> a | |||
x ^. l = get l x | |||
(&) :: t1 -> (t1 -> t2) -> t2 | |||
x & f = f x | |||
infixr 0 & | |||
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b | |||
lens sa sbt afb s = sbt s <$> afb (sa s) |
@ -0,0 +1,44 @@ | |||
{-# LANGUAGE MultiParamTypeClasses #-} | |||
{-# LANGUAGE FunctionalDependencies #-} | |||
{-# LANGUAGE FlexibleInstances #-} | |||
module Ahc.Data.Lens.Tuple where | |||
import Ahc.Data.Lens | |||
import Data.Functor.Identity | |||
class Field1 s t a b | s -> a, t -> b, s b -> t, t a -> s where | |||
_1 :: Lens s t a b | |||
instance Field1 (Identity a) (Identity a) a a where | |||
_1 = lens runIdentity (\_ x -> Identity x) | |||
instance Field1 (a, b) (a', b) a a' where | |||
_1 = lens (\(~(x, _)) -> x) (\(~(_, y)) x -> (x, y)) | |||
instance Field1 (a, b, c) (a', b, c) a a' where | |||
_1 = lens (\(~(x, _, _)) -> x) (\(~(_, y, z)) x -> (x, y, z)) | |||
instance Field1 (a, b, c, d) (a', b, c, d) a a' where | |||
_1 = lens (\(~(x, _, _, _)) -> x) (\(~(_, y, z, a)) x -> (x, y, z, a)) | |||
class Field2 s t a b | s -> a, t -> b, s b -> t, t a -> s where | |||
_2 :: Lens s t a b | |||
instance Field2 (a, b) (a, b') b b' where | |||
_2 = lens (\(~(_, y)) -> y) (\(~(x, _)) y -> (x, y)) | |||
instance Field2 (a, b, c) (a, b', c) b b' where | |||
_2 = lens (\(~(_, x, _)) -> x) (\(~(x, _, z)) y -> (x, y, z)) | |||
instance Field2 (a, b, c, d) (a, b', c, d) b b' where | |||
_2 = lens (\(~(_, x, _, _)) -> x) (\(~(x, _, z, a)) y -> (x, y, z, a)) | |||
class Field3 s t a b | s -> a, t -> b, s b -> t, t a -> s where | |||
_3 :: Lens s t a b | |||
instance Field3 (a, b, c) (a, b, c') c c' where | |||
_3 = lens (\(~(_, _, x)) -> x) (\(~(x, y, _)) z -> (x, y, z)) | |||
instance Field3 (a, b, c, d) (a, b, c', d) c c' where | |||
_3 = lens (\(~(_, _, x, _)) -> x) (\(~(x, y, _, a)) z -> (x, y, z, a)) |
@ -0,0 +1,78 @@ | |||
module Frontend.Lexer.Unicode | |||
( UnicodeClass(..) | |||
, classify | |||
, fudgeCharacterClass | |||
) where | |||
import Data.Word (Word8) | |||
import Data.Char | |||
-- | A less specfic version of 'GeneralCategory', grouping characters | |||
-- into a couple of key categories. | |||
data UnicodeClass | |||
-- These are used to designate the beginning of symbols | |||
= Upper | Lower | Symbol | |||
-- Generic and digit can be used in identifiers, but not at the start of one | |||
| Generic | Digit | |||
| Whitespace | |||
-- These are guaranteed parse order. The only difference is that "graphic" is printable, while | |||
-- other may not be. | |||
| OtherGraphic | Other | |||
deriving (Eq, Show) | |||
-- | Determine the class for a given character. | |||
classify :: Char -> UnicodeClass | |||
classify c = case generalCategory c of | |||
-- See classification descriptions in | |||
-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table> | |||
-- Cased letters | |||
UppercaseLetter -> Upper | |||
LowercaseLetter -> Lower | |||
TitlecaseLetter -> Upper | |||
ModifierLetter -> Generic | |||
OtherLetter -> Lower | |||
NonSpacingMark -> Generic | |||
SpacingCombiningMark -> OtherGraphic | |||
EnclosingMark -> OtherGraphic | |||
DecimalNumber -> Digit | |||
LetterNumber -> Generic | |||
OtherNumber -> Digit | |||
ConnectorPunctuation -> Symbol | |||
DashPunctuation -> Symbol | |||
OpenPunctuation -> OtherGraphic | |||
ClosePunctuation -> OtherGraphic | |||
InitialQuote -> OtherGraphic | |||
FinalQuote -> OtherGraphic | |||
OtherPunctuation -> Symbol | |||
MathSymbol -> Symbol | |||
CurrencySymbol -> Symbol | |||
ModifierSymbol -> Symbol | |||
-- So this _could_ be Lower or something, just so we can allow for emoji variables. | |||
-- Hrmrm, maybe not. | |||
OtherSymbol -> Symbol | |||
Space -> Whitespace | |||
-- This is all the wacky things in C* and Z* groups | |||
_ -> Other | |||
-- | Convert a character class into a fake byte which will be used by | |||
-- "Parser.Lexer" | |||
fudgeCharacterClass :: UnicodeClass -> Word8 | |||
fudgeCharacterClass Upper = 0xf0 | |||
fudgeCharacterClass Lower = 0xf1 | |||
fudgeCharacterClass Symbol = 0xf2 | |||
fudgeCharacterClass Generic = 0xf3 | |||
fudgeCharacterClass Digit = 0xf4 | |||
fudgeCharacterClass Whitespace = 0xf5 | |||
fudgeCharacterClass OtherGraphic = 0xf6 | |||
fudgeCharacterClass Other = 0xf7 |
@ -0,0 +1,56 @@ | |||
{-# LANGUAGE DeriveGeneric #-} | |||
{-# LANGUAGE DeriveAnyClass #-} | |||
module Frontend.Syntax.Var where | |||
import qualified Data.Text as T | |||
import Data.Text (Text) | |||
import Development.Shake.Classes | |||
import Frontend.Parser.Posn | |||
import GHC.Generics (Generic) | |||
data ParsedVar | |||
= UnqualVar | |||
{ varId :: Text | |||
, varBegin :: Posn | |||
, varEnd :: Posn | |||
} | |||
| QualVar | |||
{ varId :: Text | |||
, varPrefix :: Text | |||
, varBegin :: Posn | |||
, varEnd :: Posn | |||
} | |||
| ModId | |||
{ varId :: Text | |||
, varBegin :: Posn | |||
, varEnd :: Posn | |||
} | |||
| BuiltinId | |||
{ varId :: Text | |||
, varBuiltin :: BuiltinIdClass | |||
, varBegin :: Posn | |||
, varEnd :: Posn | |||
} | |||
deriving (Eq, Show, Generic, Binary, Hashable, NFData) | |||
data BuiltinIdClass | |||
= BuiltinTuple !Int | |||
| BuiltinNil | |||
| BuiltinArrow | |||
deriving (Eq, Show, Generic, Binary, Hashable, NFData) | |||
toModId :: ParsedVar -> ParsedVar | |||
toModId x@ModId{} = x | |||
toModId (UnqualVar x y z) = ModId x y z | |||
toModId (QualVar id pref b e) = ModId (pref <> T.singleton '.' <> id) b e | |||
toModId BuiltinId{} = | |||
error "Built-in variable can not be a module identifier!" | |||
splitModuleIdentifier :: Text -> [Text] | |||
splitModuleIdentifier t | |||
| T.null fst = [] | |||
| otherwise = fst:splitModuleIdentifier (T.drop 1 snd) | |||
where (fst, snd) = T.span (/= '.') t |
@ -0,0 +1,42 @@ | |||
{-# LANGUAGE TypeFamilies #-} | |||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |||
{-# LANGUAGE DeriveGeneric #-} | |||
{-# LANGUAGE DeriveAnyClass #-} | |||
{-# LANGUAGE DerivingStrategies #-} | |||
module Main.Queries where | |||
import Data.ByteString (ByteString) | |||
import Development.Shake.Classes | |||
import Development.Shake | |||
import Frontend.Syntax.Var (ParsedVar) | |||
import Frontend.Syntax (FeModule) | |||
import GHC.Generics (Generic) | |||
import Rename.Types (FqVar, RenamedMod) | |||
newtype AhcParsedModule = AhcParsedModule { ahcpmFilePath :: String } | |||
deriving newtype (Eq, Show, Binary, Hashable, NFData) | |||
type instance RuleResult AhcParsedModule = FeModule ParsedVar | |||
newtype AhcRenamedModule = AhcRenamedModule { ahcrnFilePath :: String } | |||
deriving newtype (Eq, Show, Binary, Hashable, NFData) | |||
type instance RuleResult AhcRenamedModule = RenamedMod | |||
data AhcModuleFilepath = | |||
AhcModuleFilepath | |||
{ ahcfpImportingModule :: String | |||
, ahcfpModName :: ParsedVar | |||
} | |||
deriving (Eq, Show, Generic, Binary, Hashable, NFData) | |||
type instance RuleResult AhcModuleFilepath = String | |||
newtype AhcModuleHash = AhcModuleHash { ahcmhFilePath :: String } | |||
deriving newtype (Eq, Show, Binary, Hashable, NFData) | |||
type instance RuleResult AhcModuleHash = ByteString |
@ -0,0 +1,121 @@ | |||
{-# LANGUAGE GeneralizedNewtypeDeriving #-} | |||
{-# LANGUAGE TypeFamilies #-} | |||
module Main.Rules where | |||
import Control.DeepSeq (deepseq) | |||
import Control.Concurrent | |||
import Control.Exception | |||
import Control.Monad | |||
import Crypto.Hash.SHA1 as Sha1 | |||
import qualified Data.ByteString.Lazy as Lbs | |||
import qualified Data.Text.Lazy.IO as Lt | |||
import Data.ByteString (ByteString) | |||
import qualified Data.Text as T | |||
import Data.Foldable (for_) | |||
import Development.Shake.FilePath | |||
import Development.Shake.Classes | |||
import Development.Shake | |||
import Errors | |||
import Frontend.Lexer.Wrapper (runAlex) | |||
import Frontend.Autogen.Parser | |||
import Frontend.Parser.Posn | |||
import Frontend.Syntax.Var | |||
import Frontend.Syntax | |||
import GHC.Generics (Generic) | |||
import Main.Queries | |||
import Rename.Types (FqVar, ModuleId(..), RenamedMod) | |||
import qualified Rename.Types as Rv | |||
import Rename.Rename | |||
import System.IO | |||
import Text.Show.Pretty | |||
findModuleOracle :: Rules () | |||
findModuleOracle = void $ addOracleCache find where | |||
find :: AhcModuleFilepath -> Action String | |||
find (AhcModuleFilepath our_fp (ModId id (Posn sl sc) pe)) = go "" id where | |||
go fp xs | T.null xs || not (T.singleton '.' `T.isInfixOf` xs) = do | |||
fp <- pure (fp </> T.unpack xs <.> "hs") | |||
t <- doesFileExist fp | |||
unless t . liftIO . throwIO $ | |||
emptyError { errorMessage = "file does not exist:" | |||
, errorFilename = our_fp | |||
, errorBegin = Posn sl (sc + length fp) | |||
, errorEnd = pe | |||
} | |||
pure fp | |||
go fp xs = do | |||
(x, xs) <- pure $ T.span (/= '.') xs | |||
ex <- doesDirectoryExist (T.unpack x) | |||
unless ex . liftIO . throwIO $ | |||
emptyError { errorMessage = "directory in module path does not exist:" | |||
, errorFilename = our_fp | |||
, errorBegin = Posn sl (sc + length fp) | |||
, errorEnd = Posn sl (sc + length fp + T.length x) | |||
} | |||
go (fp </> T.unpack x) xs | |||
find _ = undefined | |||
parserOracle :: Rules (String -> Action (FeModule ParsedVar)) | |||
parserOracle = fmap (. AhcParsedModule) $ addOracleCache (parse . ahcpmFilePath) where | |||
parse :: String -> Action (FeModule ParsedVar) | |||
parse fpath = do | |||
need [fpath] | |||
fileContents <- liftIO $ Lt.readFile fpath | |||
let mod = runAlex fpath fileContents parseMod | |||
() <- liftIO . evaluate $ rnf mod | |||
case mod of | |||
Left e -> liftIO $ throwIO e | |||
Right x -> pure x | |||
renamerOracle :: Rules (String -> Action RenamedMod) | |||
renamerOracle = fmap (. AhcRenamedModule) $ addOracleCache (rename . ahcrnFilePath) where | |||
rename :: String -> Action RenamedMod | |||
rename fpath = do | |||
mod <- askOracle (AhcParsedModule fpath) :: Action (FeModule ParsedVar) | |||
hash <- askOracle (AhcModuleHash fpath) | |||
mvar <- liftIO $ newMVar mempty | |||
let | |||
modid = ModuleId { Rv.moduleName = varId $ Frontend.Syntax.moduleName mod | |||
, moduleHash = hash | |||
, moduleFp = fpath | |||
} | |||
rnctx = RenameCtx { rcOurModId = modid | |||
, rcOurFilePath = fpath | |||
, rcScope = mempty | |||
, rcThisModule = mvar | |||
, rcSpanStart = Posn 1 1 | |||
, rcSpanEnd = Posn 1 1 | |||
} | |||
runRename (renameModule mod) rnctx | |||
hashOracle :: Rules (String -> Action ByteString) | |||
hashOracle = fmap (. AhcModuleHash) . addOracleCache $ \(AhcModuleHash fp) -> do | |||
need [fp] | |||
fileContents <- liftIO $ Lbs.readFile fp | |||
pure (Sha1.hashlazy fileContents) | |||
compilerRules :: [String] -> Rules () | |||
compilerRules wanted_mods = do | |||
findModuleOracle | |||
parser <- parserOracle | |||
hash <- hashOracle | |||
rename <- renamerOracle | |||
action $ do | |||
for_ wanted_mods $ \path -> do | |||
ast <- rename path | |||
liftIO $ pPrint ast |
@ -0,0 +1,252 @@ | |||
{-# LANGUAGE DeriveAnyClass #-} | |||
{-# LANGUAGE DeriveGeneric #-} | |||
{-# LANGUAGE DerivingVia #-} | |||
{-# LANGUAGE NamedFieldPuns #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE RankNTypes #-} | |||
module Rename.Rename where | |||
import Ahc.Data.Lens | |||
import Control.Monad.IO.Class | |||
import Control.Monad.Reader | |||
import Control.Concurrent | |||
import Control.Exception | |||
import qualified Data.HashMap.Strict as HashMap | |||
import Data.HashMap.Strict (HashMap) | |||
import Data.ByteString (ByteString) | |||
import Data.Text (Text) | |||
import Debug.Trace | |||
import Development.Shake ( Action, askOracle ) | |||
import Development.Shake.Classes | |||
import Errors | |||
import qualified Frontend.Syntax as Fe | |||
import Frontend.Parser.Posn | |||
import Frontend.Syntax.Var | |||
import Frontend.Syntax | |||
import GHC.Generics | |||
import Main.Queries | |||
import Rename.Types | |||
import Text.Show.Pretty | |||
import Control.Applicative | |||
newtype Rename a = RenameM { runRename :: RenameCtx -> Action a } | |||
deriving (Functor, Applicative, Monad, MonadIO, MonadReader RenameCtx) | |||
via ReaderT RenameCtx Action | |||
liftAct :: Action a -> Rename a | |||
liftAct a = RenameM $ \x -> a | |||
data RenameCtx = | |||
RenameCtx | |||
{ rcOurModId :: ModuleId | |||
, rcOurFilePath :: String | |||
, rcScope :: Scope | |||
, rcThisModule :: MVar Scope | |||
, rcSpanStart :: Posn | |||
, rcSpanEnd :: Posn | |||
} | |||
_rcScope :: Lens' RenameCtx Scope | |||
_rcScope = lens rcScope (\s x -> s { rcScope = x }) | |||
renamerSourcePos :: Posn -> Posn -> RenameCtx -> RenameCtx | |||
renamerSourcePos start end x = x { rcSpanStart = start, rcSpanEnd = end } | |||
renameModule :: FeModule ParsedVar -> Rename RenamedMod | |||
renameModule Fe.Module{moduleExports, moduleImports, moduleItems, Fe.moduleName} = do | |||
(imports, scopes) <- fmap unzip $ traverse importModule moduleImports | |||
our_mod_id <- asks rcOurModId | |||
local (extendBy (mconcat scopes)) $ do | |||
items <- renameModuleBody moduleItems | |||
this_mod <- liftIO . readMVar =<< asks rcThisModule | |||
liftIO $ print this_mod | |||
export <- traverse (renameModVarList this_mod) moduleExports | |||
our_mod_name <- makeVariable Rename.Types.Module moduleName | |||
let | |||
scope = restrictToModVarList export this_mod | |||
rnm_mod = Fe.Module { Fe.moduleName = our_mod_name | |||
, moduleExports = export | |||
, moduleImports = imports | |||
, moduleItems = items | |||
} | |||
pure (RnmMod rnm_mod scope) | |||
restrictToModVarList :: Maybe [NamespacedItem FqVar] -> Scope -> Scope | |||
restrictToModVarList Nothing x = x | |||
restrictToModVarList (Just xs) sc = foldr del sc xs where | |||
del :: NamespacedItem FqVar -> Scope -> Scope | |||
del (IEVar n) = over scopeNames (HashMap.delete (fqVarName n)) | |||
del (IECon n) = over scopeNames (HashMap.delete (fqVarName n)) . over scopeTypes (HashMap.delete (fqVarName n)) | |||
del (IEModule n) = over scopeNamespaces (HashMap.delete (fqVarName n)) | |||
renameModVarList :: Scope -> [NamespacedItem ParsedVar] -> Rename [NamespacedItem FqVar] | |||
renameModVarList sc (x:xs) = | |||
case x of | |||
IEVar pv -> | |||
case HashMap.lookup (varId pv) (sc ^. scopeNames) of | |||
Just [t] -> (IEVar t:) <$> renameModVarList sc xs | |||
_ -> notInScope pv | |||
IECon pv -> | |||
case HashMap.lookup (varId pv) (sc ^. scopeNames) <|> HashMap.lookup (varId pv) (sc ^. scopeTypes) of | |||
Just [t] -> (IECon t:) <$> renameModVarList sc xs | |||
_ -> notInScope pv | |||
IEModule pv -> | |||
case HashMap.lookup (varId pv) (sc ^. scopeNamespaces) of | |||
Just (t, _) -> (IEModule t:) <$> renameModVarList sc xs | |||
_ -> notInScope pv | |||
renameModVarList sc [] = pure [] | |||
renameModuleBody :: [ModuleItem ParsedVar] -> Rename [ModuleItem FqVar] | |||
renameModuleBody = wrap where | |||
wrap [] = pure [] | |||
wrap xs = do | |||
var <- asks rcThisModule | |||
go xs | |||
go [] = pure [] | |||
go (ModDecl (TySig vars tipe begin end) begin' end':items) = local (renamerSourcePos begin end) $ do | |||
tipe <- renameTypeToplevel tipe | |||
vars <- traverse (makeVariable_unique Variable scopeNames) vars | |||
r <- go items | |||
insertVariables scopeNames vars $ | |||
pure (ModDecl (TySig (map snd vars) tipe begin end) begin' end':r) | |||
go (x:items) = error $ "show item: " ++ ppShow x | |||
renameTypeToplevel :: FeType ParsedVar -> Rename (FeType FqVar) | |||
renameTypeToplevel (Tytup xs) = Tytup <$> traverse renameTypeToplevel xs | |||
renameTypeToplevel (SPType ty s e) = | |||
SPType <$> local (renamerSourcePos s e) (renameTypeToplevel ty) | |||
<*> pure s | |||
<*> pure e | |||
-- rename units to units | |||
renameTypeToplevel (Tycon (BuiltinId _ (BuiltinTuple 0) _ _)) = pure (Tytup []) | |||
renameTypeToplevel (Tycon x) = do | |||
var <- useVariable scopeTypes x | |||
pure (Tycon var) | |||
renameTypeToplevel x = error $ "idk how to rename: " ++ show x | |||
extendBy :: Scope -> RenameCtx -> RenameCtx | |||
extendBy s rc = rc{rcScope = s <> rcScope rc} | |||
importModule :: ModuleImport ParsedVar -> Rename (ModuleImport FqVar, Scope) | |||
importModule Import{importMod, importList, importQualified, importAlias, importBegin, importEnd} = do | |||
fp <- asks rcOurFilePath | |||
our_mod_id <- asks rcOurModId | |||
res_fp <- liftAct $ askOracle $ | |||
AhcModuleFilepath { ahcfpImportingModule = fp | |||
, ahcfpModName = importMod | |||
} | |||
renamed_import <- liftAct $ askOracle $ AhcRenamedModule res_fp | |||
let | |||
orig = rnmModSignature renamed_import | |||
other_mod = Fe.moduleName $ rnmModModule renamed_import | |||
il <- traverse (renameModVarList orig) importList | |||
orig <- pure $ restrictToModVarList il orig | |||
mod <- pure $ | |||
if importQualified | |||
then mempty { _scopeNamespaces = HashMap.singleton (varId importMod) (other_mod, orig) } | |||
else orig | |||
mod <- pure $ | |||
case importAlias of | |||
Just x -> mod & scopeNamespaces %~ HashMap.insert (varId x) (other_mod, orig) | |||
Nothing -> mod | |||
our_mod_name <- makeVariable Rename.Types.Module importMod | |||
alias <- traverse (makeVariable Rename.Types.Module) importAlias | |||
let | |||
imp = Import our_mod_name il importQualified alias importBegin importEnd | |||
pure (imp, mod) | |||
makeVariable :: MonadReader RenameCtx m => Namespace -> ParsedVar -> m FqVar | |||
makeVariable nsc x = do | |||
context <- ask | |||
pure $ | |||
FqVar { fqVarName = varId x | |||
, fqVarModule = rcOurModId context | |||
, fqVarNamespace = nsc | |||
, fqBegin = rcSpanStart context | |||
, fqEnd = rcSpanEnd context | |||
} | |||
makeVariable_unique :: Namespace -> Lens' Scope (HashMap Text [FqVar]) -> ParsedVar -> Rename (Text, FqVar) | |||
makeVariable_unique this_ns ns x = do | |||
var <- asks rcThisModule | |||
scope <- liftIO . readMVar $ var | |||
let | |||
the_hm = scope ^. ns | |||
case HashMap.lookup (varId x) the_hm of | |||
Just (orig:_) -> redeclaration orig x | |||
_ -> do | |||
new_var <- makeVariable this_ns x | |||
liftIO $ modifyMVar_ var $ \s -> pure $ over ns (insertVariable (varId x) new_var) s | |||
pure (varId x, new_var) | |||
insertVariable :: Text -> FqVar -> HashMap Text [FqVar] -> HashMap Text [FqVar] | |||
insertVariable c v = HashMap.alter go c where | |||
go (Just xs) = Just (v:xs) | |||
go Nothing = Just [v] | |||
insertVariables :: Lens' Scope (HashMap Text [FqVar]) -> [(Text, FqVar)] -> Rename a -> Rename a | |||
insertVariables lens vars = local (over (_rcScope . lens) go) where | |||
go x = foldr (\(x, y) -> insertVariable x y) x vars | |||
useVariable :: Lens' Scope (HashMap Text [FqVar]) -> ParsedVar -> Rename FqVar | |||
useVariable final_ns var = | |||
do scope <- asks rcScope | |||
go scope var | |||
where | |||
go scope (QualVar id prfx begin end) = | |||
case HashMap.lookup prfx (scope ^. scopeNamespaces) of | |||
Nothing -> notInScope var | |||
Just (_, sc) -> local (\s -> s { rcScope = sc }) $ useVariable final_ns (UnqualVar id begin end) | |||
go scope (UnqualVar id begin end) = | |||
case HashMap.lookup id (scope ^. final_ns) of | |||
Just [var] -> pure var | |||
Just vars -> ambiguousVariables vars | |||
Nothing -> notInScope var | |||
go _ x = error $ "idk how to rename yet: " ++ show x | |||
ambiguousVariables :: [FqVar] -> Rename a | |||
ambiguousVariables vs = throwRenamer $ \e -> e { errorMessage = show vs } | |||
notInScope :: HasPosn x => x -> Rename a | |||
notInScope x = | |||
local (renamerSourcePos (startPosn x) (endPosn x)) $ | |||
throwRenamer $ \e -> e { errorMessage = "variable not in scope" } | |||
redeclaration :: FqVar -> ParsedVar -> Rename a | |||
redeclaration first v = do | |||
liftIO $ pPrint first | |||
throwRenamer $ \e -> e { errorMessage = "variables can only have one declaration." | |||
, errorInlineDesc = Just "first declaration here" | |||
, errorPointers = pointTo v v "redeclaration here" | |||
, errorBegin = startPosn first | |||
, errorEnd = endPosn first | |||
} | |||
throwRenamer :: (MonadIO m, MonadReader RenameCtx m) => (AhcError -> AhcError) -> m b | |||
throwRenamer cont = do | |||
context <- ask | |||
let | |||
fname = moduleFp (rcOurModId context) | |||
errorBegin = rcSpanStart context | |||
errorEnd = rcSpanEnd context | |||
liftIO . throwIO $ cont (emptyError { errorFilename = fname, errorBegin, errorEnd }) |
@ -0,0 +1,81 @@ | |||
{-# LANGUAGE DeriveAnyClass #-} | |||
{-# LANGUAGE DeriveGeneric #-} | |||
{-# LANGUAGE StandaloneDeriving #-} | |||
module Rename.Types where | |||
import Ahc.Data.Lens (lens, Lens, Lens') | |||
import qualified Data.HashMap.Strict as HashMap | |||
import Data.HashMap.Strict (HashMap) | |||
import Data.ByteString (ByteString) | |||
import Data.Text (Text) | |||
import Development.Shake.Classes | |||
import Frontend.Parser.Posn | |||
import Frontend.Syntax | |||
import GHC.Generics | |||
data ModuleId | |||
= ModuleId { moduleName :: Text | |||
, moduleFp :: String | |||
, moduleHash :: ByteString | |||
} | |||
deriving (Eq, Show, Generic, NFData, Binary, Hashable) | |||
data Namespace | |||
= DataCon | |||
| TypeCon | |||
| Variable | |||
| Module | |||
deriving (Eq, Show, Generic, NFData, Binary, Hashable) | |||
data FqVar | |||
= FqVar { fqVarName :: Text | |||
, fqVarModule :: ModuleId | |||
, fqVarNamespace :: Namespace | |||
, fqBegin :: Posn | |||
, fqEnd :: Posn | |||
} | |||
deriving (Eq, Show, Generic, NFData, Binary, Hashable) | |||
instance HasPosn FqVar where | |||
startPosn = fqBegin | |||
endPosn = fqEnd | |||
span s e var = var { fqBegin = startPosn s, fqEnd = endPosn e } | |||
data RenamedMod | |||
= RnmMod { rnmModModule :: FeModule FqVar | |||
, rnmModSignature :: Scope } | |||
deriving (Eq, Show, Generic, NFData, Binary, Hashable) | |||
data Scope | |||
= Scope | |||
{ _scopeNames :: HashMap Text [FqVar] | |||
, _scopeTypes :: HashMap Text [FqVar] | |||
, _scopeNamespaces :: HashMap Text (FqVar, Scope) } | |||
deriving (Eq, Show, Generic, NFData, Binary, Hashable) | |||
scopeNames :: Lens' Scope (HashMap Text [FqVar]) | |||
scopeNames = lens _scopeNames (\s x -> s { _scopeNames = x}) | |||
scopeTypes :: Lens' Scope (HashMap Text [FqVar]) | |||
scopeTypes = lens _scopeTypes (\s x -> s { _scopeTypes = x}) | |||
scopeNamespaces :: Lens' Scope (HashMap Text (FqVar, Scope)) | |||
scopeNamespaces = lens _scopeNamespaces (\s x -> s { _scopeNamespaces = x}) | |||
instance Semigroup Scope where | |||
Scope nam typ ns <> Scope nam' typ' ns' | |||
= Scope (nam `merge` nam') (typ `merge` typ') (ns `merge'` ns') | |||
where | |||
merge = HashMap.unionWith (<>) | |||
merge' = HashMap.unionWith (\(x, y) (_, z) -> (x, y <> z)) | |||
instance Monoid Scope where | |||
mempty = Scope mempty mempty mempty | |||
instance (Eq k, Hashable k, Binary k, Binary v) => Binary (HashMap k v) where | |||
get = HashMap.fromList <$> get | |||
put = put . HashMap.toList |