new grammar and adapted renamer
This commit is contained in:
sebastianselander
parent
88a4a934b8
commit
936cb1301f
15 changed files with 858 additions and 821 deletions
21
src/Main.hs
21
src/Main.hs
|
|
@ -11,7 +11,8 @@ import Grammar.Print (printTree)
|
|||
import Renamer.Renamer (rename)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure, exitSuccess)
|
||||
import TypeChecker.TypeChecker (typecheck)
|
||||
|
||||
-- import TypeChecker.TypeChecker (typecheck)
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
|
|
@ -28,12 +29,12 @@ main' s = do
|
|||
putStrLn $ printTree parsed
|
||||
|
||||
putStrLn "\n-- Renamer --"
|
||||
let renamed = rename parsed
|
||||
renamed <- fromRenamerErr . rename $ parsed
|
||||
putStrLn $ printTree renamed
|
||||
|
||||
putStrLn "\n-- TypeChecker --"
|
||||
typechecked <- fromTypeCheckerErr $ typecheck renamed
|
||||
putStrLn $ show typechecked
|
||||
-- putStrLn "\n-- TypeChecker --"
|
||||
-- typechecked <- fromTypeCheckerErr $ typecheck renamed
|
||||
-- putStrLn $ show typechecked
|
||||
|
||||
-- putStrLn "\n-- Lambda Lifter --"
|
||||
-- let lifted = lambdaLift typechecked
|
||||
|
|
@ -55,6 +56,16 @@ fromCompilerErr =
|
|||
)
|
||||
pure
|
||||
|
||||
fromRenamerErr :: Err a -> IO a
|
||||
fromRenamerErr =
|
||||
either
|
||||
( \err -> do
|
||||
putStrLn "\nRENAME ERROR"
|
||||
putStrLn err
|
||||
exitFailure
|
||||
)
|
||||
pure
|
||||
|
||||
fromSyntaxErr :: Err a -> IO a
|
||||
fromSyntaxErr =
|
||||
either
|
||||
|
|
|
|||
|
|
@ -1,56 +1,101 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedRecordDot #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Renamer.Renamer where
|
||||
module Renamer.Renamer (rename) where
|
||||
|
||||
import Auxiliary (mapAccumM)
|
||||
import Control.Applicative (Applicative (liftA2))
|
||||
import Control.Monad.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Identity (Identity, runIdentity)
|
||||
import Control.Monad.State (
|
||||
MonadState,
|
||||
State,
|
||||
evalState,
|
||||
StateT,
|
||||
evalStateT,
|
||||
gets,
|
||||
modify,
|
||||
)
|
||||
import Data.List (foldl')
|
||||
import Data.Function (on)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Tuple.Extra (dupe)
|
||||
import Debug.Trace (trace)
|
||||
import Grammar.Abs
|
||||
|
||||
-- | Rename all variables and local binds
|
||||
rename :: Program -> Program
|
||||
rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
|
||||
rename :: Program -> Either String Program
|
||||
rename (Program defs) = Program <$> renameDefs defs
|
||||
|
||||
renameDefs :: [Def] -> Either String [Def]
|
||||
renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef defs) initCxt
|
||||
where
|
||||
-- initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
|
||||
initNames = Map.fromList $ foldl' saveIfBind [] bs
|
||||
saveIfBind acc (DBind (Bind name _ _ _ _)) = dupe name : acc
|
||||
saveIfBind acc _ = acc
|
||||
renameSc :: Names -> Def -> Rn Def
|
||||
renameSc old_names (DBind (Bind name t _ parms rhs)) = do
|
||||
(new_names, parms') <- newNames old_names parms
|
||||
rhs' <- snd <$> renameExp new_names rhs
|
||||
pure . DBind $ Bind name t name parms' rhs'
|
||||
renameSc _ def = pure def
|
||||
initNames = Map.fromList [dupe name | DBind (Bind name _ _) <- defs]
|
||||
|
||||
renameDef :: Def -> Rn Def
|
||||
renameDef = \case
|
||||
DSig (Sig name typ) -> DSig . Sig name <$> renameTVars typ
|
||||
DBind (Bind name vars rhs) -> do
|
||||
(new_names, vars') <- newNames initNames vars
|
||||
rhs' <- snd <$> renameExp new_names rhs
|
||||
pure . DBind $ Bind name vars' rhs'
|
||||
DData (Data (Indexed cname types) constrs) -> do
|
||||
tvars' <- mapM nextNameTVar tvars
|
||||
let tvars_lt = zip tvars tvars'
|
||||
typ' = map (substituteTVar tvars_lt) types
|
||||
constrs' = map (renameConstr tvars_lt) constrs
|
||||
pure . DData $ Data (Indexed cname typ') constrs'
|
||||
where
|
||||
tvars = concatMap (collectTVars []) types
|
||||
collectTVars tvars = \case
|
||||
TAll tvar t -> collectTVars (tvar : tvars) t
|
||||
TIndexed _ -> tvars
|
||||
-- Should be monad error
|
||||
TVar v -> [v]
|
||||
_ -> error ("Bad data type definition: " ++ show types)
|
||||
|
||||
renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor
|
||||
renameConstr new_types (Constructor name typ) =
|
||||
Constructor name $ substituteTVar new_types typ
|
||||
|
||||
substituteTVar :: [(TVar, TVar)] -> Type -> Type
|
||||
substituteTVar new_names typ = case typ of
|
||||
TLit _ -> typ
|
||||
TVar tvar
|
||||
| Just tvar' <- lookup tvar new_names ->
|
||||
TVar tvar'
|
||||
| otherwise ->
|
||||
typ
|
||||
TFun t1 t2 -> on TFun substitute' t1 t2
|
||||
TAll tvar t
|
||||
| Just tvar' <- lookup tvar new_names ->
|
||||
TAll tvar' $ substitute' t
|
||||
| otherwise ->
|
||||
TAll tvar $ substitute' t
|
||||
TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs
|
||||
_ -> error ("Impossible " ++ show typ)
|
||||
where
|
||||
substitute' = substituteTVar new_names
|
||||
|
||||
initCxt :: Cxt
|
||||
initCxt = Cxt 0 0
|
||||
|
||||
data Cxt = Cxt
|
||||
{ var_counter :: Int
|
||||
, tvar_counter :: Int
|
||||
}
|
||||
|
||||
-- | Rename monad. State holds the number of renamed names.
|
||||
newtype Rn a = Rn {runRn :: State Int a}
|
||||
deriving (Functor, Applicative, Monad, MonadState Int)
|
||||
newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
|
||||
deriving (Functor, Applicative, Monad, MonadState Cxt)
|
||||
|
||||
-- | Maps old to new name
|
||||
type Names = Map Ident Ident
|
||||
|
||||
renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
|
||||
renameLocalBind old_names (Bind name t _ parms rhs) = do
|
||||
(new_names, name') <- newName old_names name
|
||||
(new_names', parms') <- newNames new_names parms
|
||||
(new_names'', rhs') <- renameExp new_names' rhs
|
||||
pure (new_names'', Bind name' t name' parms' rhs')
|
||||
type Names = Map LIdent LIdent
|
||||
|
||||
renameExp :: Names -> Exp -> Rn (Names, Exp)
|
||||
renameExp old_names = \case
|
||||
EId n -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
|
||||
ELit (LInt i1) -> pure (old_names, ELit (LInt i1))
|
||||
ELit lit -> pure (old_names, ELit lit)
|
||||
EApp e1 e2 -> do
|
||||
(env1, e1') <- renameExp old_names e1
|
||||
(env2, e2') <- renameExp old_names e2
|
||||
|
|
@ -59,17 +104,21 @@ renameExp old_names = \case
|
|||
(env1, e1') <- renameExp old_names e1
|
||||
(env2, e2') <- renameExp old_names e2
|
||||
pure (Map.union env1 env2, EAdd e1' e2')
|
||||
ELet i e1 e2 -> do
|
||||
(new_names, e1') <- renameExp old_names e1
|
||||
(new_names', e2') <- renameExp new_names e2
|
||||
pure (new_names', ELet i e1' e2')
|
||||
|
||||
-- TODO fix shadowing
|
||||
ELet name rhs e -> do
|
||||
(new_names, name') <- newName old_names name
|
||||
(new_names', rhs') <- renameExp new_names rhs
|
||||
(new_names'', e') <- renameExp new_names' e
|
||||
pure (new_names'', ELet name' rhs' e')
|
||||
EAbs par e -> do
|
||||
(new_names, par') <- newName old_names par
|
||||
(new_names', e') <- renameExp new_names e
|
||||
pure (new_names', EAbs par' e')
|
||||
EAnn e t -> do
|
||||
(new_names, e') <- renameExp old_names e
|
||||
pure (new_names, EAnn e' t)
|
||||
t' <- renameTVars t
|
||||
pure (new_names, EAnn e' t')
|
||||
ECase e injs -> do
|
||||
(new_names, e') <- renameExp old_names e
|
||||
(new_names', injs') <- renameInjs new_names injs
|
||||
|
|
@ -88,21 +137,58 @@ renameInj ns (Inj init e) = do
|
|||
|
||||
renameInit :: Names -> Init -> Rn (Names, Init)
|
||||
renameInit ns i = case i of
|
||||
InitConstr cs vars -> do
|
||||
InitConstructor cs vars -> do
|
||||
(ns_new, vars') <- newNames ns vars
|
||||
return (ns_new, InitConstr cs vars')
|
||||
return (ns_new, InitConstructor cs vars')
|
||||
rest -> return (ns, rest)
|
||||
|
||||
renameTVars :: Type -> Rn Type
|
||||
renameTVars typ = case typ of
|
||||
TAll tvar t -> do
|
||||
tvar' <- nextNameTVar tvar
|
||||
t' <- renameTVars $ substitute tvar tvar' t
|
||||
pure $ TAll tvar' t'
|
||||
TFun t1 t2 -> liftA2 TFun (renameTVars t1) (renameTVars t2)
|
||||
_ -> pure typ
|
||||
|
||||
substitute ::
|
||||
TVar -> -- α
|
||||
TVar -> -- α_n
|
||||
Type -> -- A
|
||||
Type -- [α_n/α]A
|
||||
substitute tvar1 tvar2 typ = case typ of
|
||||
TLit _ -> typ
|
||||
TVar tvar'
|
||||
| tvar' == tvar1 -> TVar tvar2
|
||||
| otherwise -> typ
|
||||
TFun t1 t2 -> on TFun substitute' t1 t2
|
||||
TAll tvar t -> TAll tvar $ substitute' t
|
||||
TIndexed (Indexed name typs) -> TIndexed . Indexed name $ map substitute' typs
|
||||
_ -> error "Impossible"
|
||||
where
|
||||
substitute' = substitute tvar1 tvar2
|
||||
|
||||
-- | Create a new name and add it to name environment.
|
||||
newName :: Names -> Ident -> Rn (Names, Ident)
|
||||
newName :: Names -> LIdent -> Rn (Names, LIdent)
|
||||
newName env old_name = do
|
||||
new_name <- makeName old_name
|
||||
pure (Map.insert old_name new_name env, new_name)
|
||||
|
||||
-- | Create multiple names and add them to the name environment
|
||||
newNames :: Names -> [Ident] -> Rn (Names, [Ident])
|
||||
newNames :: Names -> [LIdent] -> Rn (Names, [LIdent])
|
||||
newNames = mapAccumM newName
|
||||
|
||||
-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
|
||||
makeName :: Ident -> Rn Ident
|
||||
makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ
|
||||
makeName :: LIdent -> Rn LIdent
|
||||
makeName (LIdent prefix) = do
|
||||
i <- gets var_counter
|
||||
let name = LIdent $ prefix ++ "_" ++ show i
|
||||
modify $ \cxt -> cxt{var_counter = succ cxt.var_counter}
|
||||
pure name
|
||||
|
||||
nextNameTVar :: TVar -> Rn TVar
|
||||
nextNameTVar (MkTVar (LIdent s)) = do
|
||||
i <- gets tvar_counter
|
||||
let tvar = MkTVar . LIdent $ s ++ "_" ++ show i
|
||||
modify $ \cxt -> cxt{tvar_counter = succ cxt.tvar_counter}
|
||||
pure tvar
|
||||
|
|
|
|||
|
|
@ -1,83 +0,0 @@
|
|||
## Bugs
|
||||
|
||||
None known at this moment
|
||||
|
||||
main\_bug should not typecheck
|
||||
|
||||
```hs
|
||||
apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
|
||||
apply f x = \y. f x y ;
|
||||
|
||||
id : 'a -> 'a ;
|
||||
id x = x ;
|
||||
|
||||
add : _Int -> _Int -> _Int ;
|
||||
add x y = x + y ;
|
||||
|
||||
main_bug : _Int -> _Int -> _Int ;
|
||||
main_bug= (apply id) add ;
|
||||
|
||||
idadd : _Int -> _Int -> _Int ;
|
||||
idadd = id add ;
|
||||
```
|
||||
|
||||
main\_bug should typecheck
|
||||
|
||||
```hs
|
||||
apply : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c ;
|
||||
apply f x = \y. f x y ;
|
||||
|
||||
id : 'a -> 'a ;
|
||||
id x = x ;
|
||||
|
||||
add : _Int -> _Int -> _Int ;
|
||||
add x y = x + y ;
|
||||
|
||||
main_bug : _Int -> _Int -> _Int ;
|
||||
main_bug = apply (id add) ;
|
||||
|
||||
idadd : _Int -> _Int -> _Int ;
|
||||
idadd = id add ;
|
||||
```
|
||||
|
||||
## Fixed bugs
|
||||
|
||||
* 1
|
||||
|
||||
```hs
|
||||
fmap : ('a -> 'b) -> Maybe ('a) -> Maybe ('b) ;
|
||||
fmap f x =
|
||||
case x of {
|
||||
Just x => Just (f x) ;
|
||||
Nothing => Nothing
|
||||
}
|
||||
```
|
||||
|
||||
* 2
|
||||
|
||||
```hs
|
||||
data Maybe ('a) where {
|
||||
Nothing : Maybe ('a)
|
||||
Just : 'a -> Maybe ('a)
|
||||
};
|
||||
|
||||
id : 'a -> 'a ;
|
||||
id x = x ;
|
||||
|
||||
main : Maybe ('a -> 'a) ;
|
||||
main = Just id;
|
||||
```
|
||||
|
||||
But this does
|
||||
```hs
|
||||
data Maybe ('a) where {
|
||||
Nothing : Maybe ('a)
|
||||
Just : 'a -> Maybe ('a)
|
||||
};
|
||||
|
||||
id : 'b -> 'b ;
|
||||
id x = x ;
|
||||
|
||||
main : Maybe ('a -> 'a) ;
|
||||
main = Just id;
|
||||
```
|
||||
File diff suppressed because it is too large
Load diff
|
|
@ -2,178 +2,178 @@
|
|||
|
||||
module TypeChecker.TypeCheckerIr where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Data.Map (Map)
|
||||
import Grammar.Abs (
|
||||
Data (..),
|
||||
Ident (..),
|
||||
Init (..),
|
||||
Literal (..),
|
||||
Type (..),
|
||||
)
|
||||
import Grammar.Print
|
||||
import Prelude
|
||||
import Prelude qualified as C (Eq, Ord, Read, Show)
|
||||
-- import Control.Monad.Except
|
||||
-- import Control.Monad.Reader
|
||||
-- import Control.Monad.State
|
||||
-- import Data.Functor.Identity (Identity)
|
||||
-- import Data.Map (Map)
|
||||
-- import Grammar.Abs (
|
||||
-- Data (..),
|
||||
-- Ident (..),
|
||||
-- Init (..),
|
||||
-- Literal (..),
|
||||
-- Type (..),
|
||||
-- )
|
||||
-- import Grammar.Print
|
||||
-- import Prelude
|
||||
-- import Prelude qualified as C (Eq, Ord, Read, Show)
|
||||
|
||||
-- | A data type representing type variables
|
||||
data Poly = Forall [Ident] Type
|
||||
deriving (Show)
|
||||
-- -- | A data type representing type variables
|
||||
-- data Poly = Forall [Ident] Type
|
||||
-- deriving (Show)
|
||||
|
||||
newtype Ctx = Ctx {vars :: Map Ident Poly}
|
||||
deriving Show
|
||||
-- newtype Ctx = Ctx {vars :: Map Ident Poly}
|
||||
-- deriving Show
|
||||
|
||||
data Env = Env
|
||||
{ count :: Int
|
||||
, sigs :: Map Ident Type
|
||||
, constructors :: Map Ident Type
|
||||
} deriving Show
|
||||
-- data Env = Env
|
||||
-- { count :: Int
|
||||
-- , sigs :: Map Ident Type
|
||||
-- , constructors :: Map Ident Type
|
||||
-- } deriving Show
|
||||
|
||||
type Error = String
|
||||
type Subst = Map Ident Type
|
||||
-- type Error = String
|
||||
-- type Subst = Map Ident Type
|
||||
|
||||
type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
|
||||
-- type Infer = StateT Env (ReaderT Ctx (ExceptT Error Identity))
|
||||
|
||||
newtype Program = Program [Def]
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
-- newtype Program = Program [Def]
|
||||
-- deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
data Exp
|
||||
= EId Id
|
||||
| ELit Type Literal
|
||||
| ELet Bind Exp
|
||||
| EApp Type Exp Exp
|
||||
| EAdd Type Exp Exp
|
||||
| EAbs Type Id Exp
|
||||
| ECase Type Exp [Inj]
|
||||
deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
-- data Exp
|
||||
-- = EId Id
|
||||
-- | ELit Type Literal
|
||||
-- | ELet Bind Exp
|
||||
-- | EApp Type Exp Exp
|
||||
-- | EAdd Type Exp Exp
|
||||
-- | EAbs Type Id Exp
|
||||
-- | ECase Type Exp [Inj]
|
||||
-- deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
|
||||
data Inj = Inj (Init, Type) Exp
|
||||
deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
-- data Inj = Inj (Init, Type) Exp
|
||||
-- deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
|
||||
data Def = DBind Bind | DData Data
|
||||
deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
-- data Def = DBind Bind | DData Data
|
||||
-- deriving (C.Eq, C.Ord, C.Read, C.Show)
|
||||
|
||||
type Id = (Ident, Type)
|
||||
-- type Id = (Ident, Type)
|
||||
|
||||
data Bind = Bind Id Exp
|
||||
deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
-- data Bind = Bind Id Exp
|
||||
-- deriving (C.Eq, C.Ord, C.Show, C.Read)
|
||||
|
||||
instance Print [Def] where
|
||||
prt _ [] = concatD []
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
|
||||
-- instance Print [Def] where
|
||||
-- prt _ [] = concatD []
|
||||
-- prt _ (x : xs) = concatD [prt 0 x, doc (showString "\n"), prt 0 xs]
|
||||
|
||||
instance Print Def where
|
||||
prt i (DBind bind) = prt i bind
|
||||
prt i (DData d) = prt i d
|
||||
-- instance Print Def where
|
||||
-- prt i (DBind bind) = prt i bind
|
||||
-- prt i (DData d) = prt i d
|
||||
|
||||
instance Print Program where
|
||||
prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||
-- instance Print Program where
|
||||
-- prt i (Program sc) = prPrec i 0 $ prt 0 sc
|
||||
|
||||
instance Print Bind where
|
||||
prt i (Bind (t, name) rhs) =
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, doc $ showString "\n"
|
||||
, prt 0 name
|
||||
, doc $ showString "="
|
||||
, prt 0 rhs
|
||||
]
|
||||
-- instance Print Bind where
|
||||
-- prt i (Bind (t, name) rhs) =
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ prt 0 name
|
||||
-- , doc $ showString ":"
|
||||
-- , prt 0 t
|
||||
-- , doc $ showString "\n"
|
||||
-- , prt 0 name
|
||||
-- , doc $ showString "="
|
||||
-- , prt 0 rhs
|
||||
-- ]
|
||||
|
||||
instance Print [Bind] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
|
||||
-- instance Print [Bind] where
|
||||
-- prt _ [] = concatD []
|
||||
-- prt _ [x] = concatD [prt 0 x]
|
||||
-- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), doc (showString "\n"), prt 0 xs]
|
||||
|
||||
prtIdPs :: Int -> [Id] -> Doc
|
||||
prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
|
||||
-- prtIdPs :: Int -> [Id] -> Doc
|
||||
-- prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
|
||||
|
||||
prtId :: Int -> Id -> Doc
|
||||
prtId i (name, t) =
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
]
|
||||
-- prtId :: Int -> Id -> Doc
|
||||
-- prtId i (name, t) =
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ prt 0 name
|
||||
-- , doc $ showString ":"
|
||||
-- , prt 0 t
|
||||
-- ]
|
||||
|
||||
prtIdP :: Int -> Id -> Doc
|
||||
prtIdP i (name, t) =
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ doc $ showString "("
|
||||
, prt 0 name
|
||||
, doc $ showString ":"
|
||||
, prt 0 t
|
||||
, doc $ showString ")"
|
||||
]
|
||||
-- prtIdP :: Int -> Id -> Doc
|
||||
-- prtIdP i (name, t) =
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ doc $ showString "("
|
||||
-- , prt 0 name
|
||||
-- , doc $ showString ":"
|
||||
-- , prt 0 t
|
||||
-- , doc $ showString ")"
|
||||
-- ]
|
||||
|
||||
instance Print Exp where
|
||||
prt i = \case
|
||||
EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
|
||||
ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
|
||||
ELet bs e ->
|
||||
prPrec i 3 $
|
||||
concatD
|
||||
[ doc $ showString "let"
|
||||
, prt 0 bs
|
||||
, doc $ showString "in"
|
||||
, prt 0 e
|
||||
, doc $ showString "\n"
|
||||
]
|
||||
EApp _ e1 e2 ->
|
||||
prPrec i 2 $
|
||||
concatD
|
||||
[ prt 2 e1
|
||||
, prt 3 e2
|
||||
]
|
||||
EAdd t e1 e2 ->
|
||||
prPrec i 1 $
|
||||
concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, prt 1 e1
|
||||
, doc $ showString "+"
|
||||
, prt 2 e2
|
||||
, doc $ showString "\n"
|
||||
]
|
||||
EAbs t n e ->
|
||||
prPrec i 0 $
|
||||
concatD
|
||||
[ doc $ showString "@"
|
||||
, prt 0 t
|
||||
, doc $ showString "\\"
|
||||
, prtId 0 n
|
||||
, doc $ showString "."
|
||||
, prt 0 e
|
||||
, doc $ showString "\n"
|
||||
]
|
||||
ECase t exp injs ->
|
||||
prPrec
|
||||
i
|
||||
0
|
||||
( concatD
|
||||
[ doc (showString "case")
|
||||
, prt 0 exp
|
||||
, doc (showString "of")
|
||||
, doc (showString "{")
|
||||
, prt 0 injs
|
||||
, doc (showString "}")
|
||||
, doc (showString ":")
|
||||
, prt 0 t
|
||||
, doc $ showString "\n"
|
||||
]
|
||||
)
|
||||
-- instance Print Exp where
|
||||
-- prt i = \case
|
||||
-- EId n -> prPrec i 3 $ concatD [prtId 0 n, doc $ showString "\n"]
|
||||
-- ELit _ (LInt i1) -> prPrec i 3 $ concatD [prt 0 i1, doc $ showString "\n"]
|
||||
-- ELet bs e ->
|
||||
-- prPrec i 3 $
|
||||
-- concatD
|
||||
-- [ doc $ showString "let"
|
||||
-- , prt 0 bs
|
||||
-- , doc $ showString "in"
|
||||
-- , prt 0 e
|
||||
-- , doc $ showString "\n"
|
||||
-- ]
|
||||
-- EApp _ e1 e2 ->
|
||||
-- prPrec i 2 $
|
||||
-- concatD
|
||||
-- [ prt 2 e1
|
||||
-- , prt 3 e2
|
||||
-- ]
|
||||
-- EAdd t e1 e2 ->
|
||||
-- prPrec i 1 $
|
||||
-- concatD
|
||||
-- [ doc $ showString "@"
|
||||
-- , prt 0 t
|
||||
-- , prt 1 e1
|
||||
-- , doc $ showString "+"
|
||||
-- , prt 2 e2
|
||||
-- , doc $ showString "\n"
|
||||
-- ]
|
||||
-- EAbs t n e ->
|
||||
-- prPrec i 0 $
|
||||
-- concatD
|
||||
-- [ doc $ showString "@"
|
||||
-- , prt 0 t
|
||||
-- , doc $ showString "\\"
|
||||
-- , prtId 0 n
|
||||
-- , doc $ showString "."
|
||||
-- , prt 0 e
|
||||
-- , doc $ showString "\n"
|
||||
-- ]
|
||||
-- ECase t exp injs ->
|
||||
-- prPrec
|
||||
-- i
|
||||
-- 0
|
||||
-- ( concatD
|
||||
-- [ doc (showString "case")
|
||||
-- , prt 0 exp
|
||||
-- , doc (showString "of")
|
||||
-- , doc (showString "{")
|
||||
-- , prt 0 injs
|
||||
-- , doc (showString "}")
|
||||
-- , doc (showString ":")
|
||||
-- , prt 0 t
|
||||
-- , doc $ showString "\n"
|
||||
-- ]
|
||||
-- )
|
||||
|
||||
instance Print Inj where
|
||||
prt i = \case
|
||||
Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
|
||||
-- instance Print Inj where
|
||||
-- prt i = \case
|
||||
-- Inj (init, t) exp -> prPrec i 0 (concatD [prt 0 init, doc (showString ":"), prt 0 t, doc (showString "=>"), prt 0 exp])
|
||||
|
||||
instance Print [Inj] where
|
||||
prt _ [] = concatD []
|
||||
prt _ [x] = concatD [prt 0 x]
|
||||
prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
-- instance Print [Inj] where
|
||||
-- prt _ [] = concatD []
|
||||
-- prt _ [x] = concatD [prt 0 x]
|
||||
-- prt _ (x : xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue