push inicial

README.md

+# Bienvenidos al Compilador!
+
+Esta es una versión vieja del compilador en Haskell. Se tiene todo lo que se necesita
+más un montón de cosas que no se necesitan.
+
+Está pensado para ser desarrollado en 2 partes, [Haskell1] vendría a ser una suerte de
+primer entrega, y [Haskell2] vendría a ser lo que falta para la segunda parte.

haskell1/.gitignore

+*.swp
+*.hi
+*.o
+*.swo

haskell1/EscapTesting.hs

+
+import TigerAbs
+import TigerEscap
+import qualified Data.Text as T
+
+ejemplo1 :: Exp -- La variable a escapa.
+ejemplo1 = LetExp
+            [ VarDec (T.pack "a") Nothing Nothing (IntExp 1 (1,1)) (1,2)
+            , FunctionDec
+                    [ (T.pack "f1",[( T.pack "a1", Nothing, NameTy $ T.pack "int")], Just $ T.pack "int",VarExp (SimpleVar $ T.pack "a") (5,5),(5,2))]
+            ]
+            (IntExp 42 (8,1))
+            (1,0)
+
+ejemplo2 :: Exp -- La variable b no está definida.
+ejemplo2 = LetExp
+            [ VarDec (T.pack "a") Nothing Nothing (IntExp 1 (1,2)) (1,2)
+            -- , VarDec "b" Nothing Nothing (IntExp 2 1) 2
+            -- , VarDec "c" Nothing Nothing (IntExp 3 1) 3
+            , FunctionDec
+                    [ (T.pack "f1",[(T.pack "a1", Nothing, NameTy $ T.pack "int")], Just $ T.pack "int",VarExp (SimpleVar $ T.pack "b") (5,5),(5,6))]
+            ]
+            (IntExp 42 (8,1))
+            (1,0)

haskell1/TigerAbs.hs

+{-# LANGUAGE GADTs #-}
+module TigerAbs where
+
+import           TigerSymbol
+
+-- | Pos representa la posición, simple de una linea y columna, o bien un rango
+-- de posiciones
+data Pos = Simple {line::Int, col :: Int} | Range Pos Pos
+    deriving Show
+
+posToLabel :: Pos -> String
+posToLabel (Simple l r) = (show l) ++ '.':(show r)
+posToLabel (Range l r) = (posToLabel l) ++ '.':(posToLabel r)
+
+printPos :: Pos -> String
+printPos (Simple l c) = "[L:" ++ show l ++".C:"++ show c++"]"
+printPos (Range b e) = "Entre --" ++ printPos b ++ " | " ++ printPos e
+
+-- | Representamos las variables
+data Var where
+    -- | Nombre de variable. Por ejemplo '(a+1)', 'a' se representa con una
+    -- SimpleVar "a".
+    SimpleVar :: Symbol -> Var
+    -- | Representa el acceso a un campo particular de un record. Pj: a.pepe.
+    -- daría a la construcción de FieldVar (SimpleVar "a") "pepe"
+    FieldVar :: Var -> Symbol -> Var
+    -- | Representa el acceso a un elemento de un array. Pj: a[(3+4)]. Daría a
+    -- la construcción de: SubscriptVar (SimpleVar "a") (OpExp (IntExp 3) PlusOp
+    -- (IntExp 4))
+    SubscriptVar :: Var -> Exp -> Var
+    deriving Show
+
+-- | Tipo que representa las expresiones de tiger! Todos los constructores
+-- llevan la posición en la que se encuentra el texto en el código fuente que
+-- dio lugar a la construcción del AST.
+data Exp where
+    -- | Representa una variable, el resultado es otorgar el valor de la
+    -- variable.
+    VarExp :: Var -> Pos -> Exp
+    -- | Unit, no es posible escribir unit en el lenguaje fuente.
+    UnitExp :: Pos -> Exp
+    -- | Break
+    BreakExp :: Pos -> Exp
+    -- | Nil
+    NilExp :: Pos -> Exp
+    -- | Enteros
+    IntExp :: Int -> Pos -> Exp
+    -- | Cadenas de texto
+    StringExp :: String -> Pos -> Exp
+    -- | Llamada de una función. Ej: f (45). Daría lugar al sig árbol: CallExp
+    -- "f" [IntExp 45] Pos
+    CallExp :: Symbol -> [Exp] -> Pos -> Exp
+    -- | Operaciones. Ej: 3+4. (OpExp (IntExp 3) PlusOp (IntExp 4))
+    OpExp :: Exp -> Oper -> Exp -> Pos -> Exp
+    -- | Records, representa un valor de un tipo record. Pj: lista{hd=1;tail=nil}
+    -- nos daría un AST: RecordExp [("hd",IntExp 1),("tail",NilExp)] "lista"
+    -- Pos. Recuerden, nos genera un valor de tipo record.
+    RecordExp :: [(Symbol, Exp)] -> Symbol -> Pos -> Exp
+    -- | SEcuencia de expresiones, el valor debería estar dictado por la ultima.
+    -- Ej: 4 ; print("Holis") ;  0. Genera: SeqExp [IntExp 4 Pos,
+    -- CallExp "print" [StringExp "Holis"] Pos, IntExp 0 Pos]  Pos
+    SeqExp :: [Exp] -> Pos -> Exp
+    -- | Asignación. Ej: a := 3. AssignExp (SimpleVar "a") (IntExp 3 Pos) Pos
+    AssignExp :: Var -> Exp -> Pos -> Exp
+    -- | Condicional. Ej: if 3 then print("pepe"). Genera: IfExp (IntExp 3 Pos)
+    -- (CallExp "print" ["pepe"] Pos) NONE Pos
+    IfExp :: Exp -> Exp -> Maybe Exp -> Pos -> Exp
+    -- | Bucle while.
+    WhileExp :: Exp -> Exp -> Pos -> Exp
+    -- | Bucle for.
+    ForExp :: Symbol -> Maybe Bool -> Exp -> Exp -> Exp -> Pos -> Exp
+    -- | Expresiones tipo let. Es el único lugar donde pueden declarar nuevas
+    -- varibles, tipos y funciones. Ej: let var a := 3 in a end genera el árbol:
+    -- LetExp [VarDec "a" Nothing Nothing (IntExp 3 Pos) Pos] (SimpleVar "a")
+    -- Pos
+    LetExp :: [Dec] -> Exp -> Pos -> Exp
+    -- | Representa un valor de tipo Arreglo. Nos define un nuevo valor de tipo
+    -- arreglo. Pj: intArray [3+4] of (2*2). Nos genra el árbol: ArrayExp
+    -- "intArray" (OpExp (IntExp 3 Pos) PlusOp (IntExp 4 Pos)) (OpExp (IntExp 2
+    -- Pos) TimesOp (IntExp 2 Pos)) Pos
+    ArrayExp :: Symbol -> Exp -> Exp -> Pos -> Exp
+    deriving Show
+
+-- | Declaraciones!
+data Dec where
+    FunctionDec :: [(Symbol,[Field], Maybe Symbol, Exp, Pos)] -> Dec
+    VarDec :: Symbol -> Maybe Bool -> Maybe Symbol -> Exp -> Pos -> Dec
+    TypeDec :: [(Symbol, Ty, Pos)] -> Dec
+    deriving Show
+
+data Ty = NameTy Symbol | RecordTy [Field] | ArrayTy Symbol
+    deriving Show
+
+data Oper = PlusOp | MinusOp | TimesOp | DivideOp | EqOp | NeqOp | LtOp | LeOp | GtOp | GeOp
+    deriving Show
+
+type Field = (Symbol, Maybe Bool, Ty)

haskell1/TigerEnv.hs

+module TigerEnv where
+
+-- import qualified Data.Map.Strict as M
+-- import qualified Data.List as L
+
+class Environmental w where
+    lookupI ::(Ord a) => a -> w a d -> Maybe d -- Buscar
+    insertI ::(Ord a) => a -> d -> w a d -> w a d
+    intersecI :: (Ord a) =>  (d -> d -> d) -> w a d -> w a d -> w a d
+    updateI :: (Ord a) => a -> d -> w a d -> w a d
+    emptyI :: w a d
+
+fromList :: (Ord a, Environmental m) => [(a,k)] -> m a k
+fromList = foldl (\env (k,d) -> insertI k d env) emptyI

haskell1/TigerErrores.hs

+module TigerErrores where
+
+import           TigerSymbol
+
+class Daemon w where
+    derror :: Symbol -> w a
+    handle :: w a -> (Symbol -> w a) -> w a
+    adder :: w a -> Symbol -> w a
+    adder w s = handle w (derror . append s)
+    internal :: Symbol -> w a
+    internal = derror . addStr "Internal: "
+    notfound :: Symbol -> w a
+    notfound  = derror . addStr "Not found:"

haskell1/TigerEscap.hs

+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+module TigerEscap where
+
+import           Data.Functor.Identity
+import qualified Data.Map.Strict       as M
+import           Data.Maybe
+import           Prelude               hiding (error, lookup)
+import qualified Prelude               as P (error)
+import           TigerAbs
+import           TigerEnv
+import           TigerErrores
+
+import           TigerSymbol
+
+import           Control.Monad         (when)
+import           Control.Monad.Except
+import           Control.Monad.State   (get, put)
+import qualified Control.Monad.State   as ST
+
+-- Debugging
+import           Debug.Trace
+
+data Errores =  NotFound Symbol
+                | Interno Symbol
+
+instance Show Errores where
+    show (NotFound e) = "No se encuentra la variable "++ show e
+    show (Interno e) = "Error interno " ++ show e
+
+eappend (NotFound e) e1 = NotFound (append e e1)
+eappend (Interno e) e1 = Interno (append e e1)
+
+type Depth = Int
+type Dat = (Int , Maybe Bool)
+type Env = M.Map Symbol Dat
+data Estado = S { lvl :: Int, env :: Env}
+    deriving Show
+
+data SEstado = Step { l :: Int, e :: [Env]}
+    deriving Show
+
+class (Daemon m, Monad m) => Escapator m where
+    -- Depth Operators
+    depth :: m Depth
+    up :: m ()
+    down :: m ()
+    -- Env operators
+    setEnv :: M.Map Symbol Dat -> m ()
+    getEnv :: m (M.Map Symbol Dat)
+    --
+    -- Funciones cpor default, o de debugging
+    -- debugging
+    printEnv :: m () --
+    -- errores
+    putNum :: Pos -> Symbol -> m a
+    putNum ln er = derror $ append er $ pack $ printPos ln
+    raise :: Symbol -> m a
+    raise = derror
+    ---
+    update :: Symbol -> Maybe Bool -> m ()
+    update s mb = do
+        m <- getEnv
+        case M.lookup s m of
+             Nothing -> notfound s
+             (Just (l,_)) -> setEnv (M.insert s (l,mb) m)
+    lookup :: Symbol -> m (Maybe (Int, Maybe Bool))
+    lookup s = do
+        m <- getEnv
+        return $ M.lookup s m
+    insert :: Symbol -> Maybe Bool -> m (M.Map Symbol Dat)
+    insert s mb = do
+        old <- getEnv
+        lvl <- depth
+        setEnv (M.insert s (lvl,mb) old)
+        return old
+    updateEnv :: M.Map Symbol Dat -> m ()
+    updateEnv m = do
+        actual <- getEnv
+        let newEnv = M.intersectionWith (\ (olvl, oesc) (nlvl,nesc) -> if olvl == nlvl then (olvl, nesc) else (olvl,oesc)) m actual
+        setEnv newEnv
+
+type Stepper = ST.StateT SEstado (Either Errores)
+
+instance Daemon Stepper where
+    derror = throwError . Interno
+    handle m f = catchError m ( f . pack . show)
+
+instance Escapator Stepper where
+    depth = do
+        s <- ST.get
+        return (l s)
+    up = do
+        (Step lvl env) <- ST.get
+        ST.put (Step (lvl+1) env)
+    down = do
+        (Step lvl env) <- ST.get
+        ST.put (Step (lvl-1) env)
+    setEnv e = do
+        (Step lvl xs) <- get
+        put (Step lvl (e:xs))
+    getEnv = do
+        (Step _ (e:es)) <- ST.get
+        return e
+    printEnv = do
+        (Step l env) <- ST.get
+        return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
+
+
+type Completor = ST.StateT Estado (Either Errores)
+
+instance Daemon Completor where
+    derror = throwError . Interno
+    handle m f = catchError m (f . pack . show)
+    adder e e1 = handle e (\s -> derror $ append e1 s )
+
+instance Escapator Completor where
+    depth = do
+        s <- ST.get
+        return (lvl s)
+    up = do
+        (S lvl env) <- ST.get
+        ST.put (S (lvl+1) env)
+    down = do
+        (S lvl env) <- ST.get
+        ST.put (S (lvl-1) env)
+    setEnv e = do
+        (S lvl _) <- get
+        put (S lvl e)
+    getEnv = do
+        (S _ e) <- get
+        return e
+    printEnv = do
+        (S l env) <- get
+        return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
+
+type Simpler= ST.State Estado -- Sin manejo de Errores...
+
+instance Daemon Simpler where
+    derror s = P.error $ unpack s
+    handle m _ = m -- no se maneja esto..
+
+instance Escapator Simpler where -- No error
+    depth = do
+        s <- ST.get
+        return (lvl s)
+    up = do
+        (S lvl env) <- ST.get
+        ST.put (S (lvl+1) env)
+    down = do
+        (S lvl env) <- ST.get
+        ST.put (S (lvl-1) env)
+    setEnv e = do
+        (S lvl _) <- get
+        put (S lvl e)
+    getEnv = do
+        (S _ e) <- get
+        return e
+    printEnv = do
+        (S l env) <- get
+        return (trace ("Entorno(" ++ show l ++")" ++ show env ++ "*****\n") ())
+
+travVar :: (Escapator m) => Var -> m Var
+travVar (SimpleVar s) = do
+    s' <- lookup s
+    actLvl <- depth
+    case s' of
+        Nothing -> notfound s
+        Just (lvl, esc) -> when (actLvl > lvl) $ update s (Just True)
+    return (SimpleVar s)
+travVar (FieldVar v p) = do
+    v' <- travVar v -- v._
+    return (FieldVar v' p)
+travVar (SubscriptVar v e) = do
+        v' <- travVar v
+        e' <- travExp e
+        return (SubscriptVar v' e')
+
+travExp :: (Escapator m) => Exp -> m Exp
+travExp (VarExp v p) = do
+    v' <- handle (travVar v) (putNum p)
+    return (VarExp v' p)
+travExp (CallExp s args p) = do
+    args' <- mapM travExp args
+    return (CallExp s args' p)
+travExp (OpExp l op r p) = do
+    l' <- travExp l
+    r' <- travExp r
+    return (OpExp l' op r' p)
+travExp (RecordExp es s p) = do
+    es' <- mapM (\(s,e) -> do
+                                e' <- travExp e
+                                return (s,e')) es
+    return (RecordExp es' s p)
+travExp (SeqExp es p) = do
+    es' <- mapM travExp es
+    return (SeqExp es' p)
+travExp (AssignExp v e p) = do
+    v' <- handle (travVar v) (putNum p)
+    e' <- travExp e
+    return (AssignExp v' e' p)
+travExp (IfExp c t Nothing p) = do
+    c' <- travExp c
+    t' <- travExp t
+    return (IfExp c' t' Nothing p)
+travExp (IfExp c t (Just e) p) = do
+    c' <- travExp c
+    t' <- travExp t
+    e' <- travExp e
+    return (IfExp c' t' (Just e') p)
+travExp (WhileExp c b p) = do
+    c' <- travExp c
+    b' <- travExp b
+    return (WhileExp c' b' p)
+travExp (ForExp s e lo hi body p) = do
+    lo' <- travExp lo
+    hi' <- travExp hi
+    old <- insert s e
+    body' <- travExp body
+    setEnv old
+    return (ForExp s e lo' hi' body' p)
+travExp (LetExp ds e p) = do
+    old <- getEnv  -- Security Measures <--
+    ds' <- mapM travDecs ds
+    e' <- travExp e
+    ds'' <- mapM (\case
+                    (VarDec name _ typ exp p) -> do
+                        chk <- lookup name
+                        case chk of
+                            Nothing -> internal $ pack $ "666+1 -- Linea:" ++ show p
+                            Just (_,esc) ->
+                                let newvardec = VarDec name esc typ exp p in
+                                 return newvardec
+                    l -> return l) ds'
+    updateEnv old
+    return (LetExp ds'' e' p)
+travExp (ArrayExp typ size init p) = do
+    s' <- travExp size
+    init' <- travExp init
+    return (ArrayExp typ s' init' p)
+travExp v = return v
+
+travF :: (Escapator m) => (Symbol,[Field], Maybe Symbol, Exp, Pos) -> m (Symbol,[Field], Maybe Symbol, Exp, Pos)
+travF (name, params, res, body, p) = do
+    old <- getEnv
+    mapM_ (\(name, esc, typ) -> insert name esc) params
+    body' <- travExp body
+    params' <- mapM (\(s,_,ty) -> do
+                                mb <- lookup s
+                                case mb of
+                                    Nothing -> internal $ pack $ "666+2 -- Linea:" ++ show p
+                                    Just (_,esc) -> return (s,esc,ty)) params
+    updateEnv old
+    return (name, params', res, body', p)
+travDecs ::  (Escapator m) => Dec -> m Dec
+travDecs (FunctionDec ls) = do
+    up -- New level!!
+    ls' <- mapM travF ls
+    down -- Return to old lvl
+    return (FunctionDec ls')
+travDecs (VarDec name esc typ init p) = do
+    init' <- travExp init
+    insert name esc
+    return (VarDec name esc typ init' p)
+travDecs l = return l
+
+initialSt :: Estado
+initialSt = S 1 M.empty
+
+calcularEsc :: Exp -> Exp
+calcularEsc e = ST.evalState (travExp e) initialSt
+
+showEnv :: Exp -> (Exp,Estado)
+showEnv e = ST.runState (travExp e) initialSt
+
+calcularEEsc :: Exp -> Either Errores Exp
+calcularEEsc e = ST.evalStateT (travExp e) initialSt
+
+initialStepper :: SEstado
+initialStepper = Step 1 [M.empty]
+
+debbugEnv :: Exp -> Either Errores (Exp,SEstado)
+debbugEnv e = ST.runStateT (travExp e) initialStepper

haskell1/TigerLexer.hs

+module TigerLexer where
+
+import TigerAbs
+import qualified Data.Text as T
+
+import Text.Parsec
+import qualified Text.Parsec.Token as Tok
+-- import Text.Parsec.Char
+import qualified Text.Parsec.Text as PT
+-- import Data.Functor.Identity
+
+lexer :: Tok.TokenParser () 
+lexer = Tok.makeTokenParser  Tok.LanguageDef
+    {Tok.commentStart = "/*"
+    ,Tok.commentEnd = "*/"
+    ,Tok.commentLine = []
+    ,Tok.nestedComments = True
+    ,Tok.identStart = letter
+    ,Tok.identLetter = alphaNum <|> char '_'
+    ,Tok.opStart = oneOf ":,;=&|<=>+-*/." 
+    ,Tok.opLetter = char '='
+    ,Tok.reservedNames = ["var","let","end","in","function","type","array","of","if","then","else","while","do","for","to","break","nil","()"]
+    ,Tok.reservedOpNames = ["=","&","|","<","<=",">",">=","<>","+","-","*","/","\""]
+    ,Tok.caseSensitive = False
+}
+
+reservedOp = Tok.reservedOp lexer
+reserved = Tok.reserved lexer
+
+toInt :: Integer -> Int
+toInt = fromInteger
+-- number :: PT.Parser Integer
+number = do
+    n <- Tok.natural lexer
+    return (toInt n)
+parens = Tok.parens lexer
+commaSep = Tok.commaSep lexer
+commaSep1 = Tok.commaSep1 lexer
+semiSep = Tok.semiSep lexer
+semiSep1 = Tok.semiSep1 lexer
+identifier = Tok.identifier lexer
+dot = Tok.dot lexer
+colon = Tok.colon lexer
+brackets = Tok.brackets lexer
+braces = Tok.braces lexer
+symbol = Tok.symbol lexer
+stringLiteral = Tok.stringLiteral lexer
+whiteSpace = Tok.whiteSpace lexer

haskell1/TigerMain.hs

+module Main (main) where
+import qualified System.Environment as Env
+import System.Exit
+import System.Console.GetOpt
+import Control.Monad
+import Data.Maybe
+import Data.Either
+
+import TigerAbs
+import TigerParser
+import TigerEscap
+import TigerPretty
+import TigerSeman
+
+import Text.Parsec (runParser)
+
+data Options = Options {
+        optArbol :: Bool
+        ,optDebEscap :: Bool
+    }
+    deriving Show
+
+defaultOptions :: Options
+defaultOptions = Options {optArbol = False, optDebEscap = False }
+
+options :: [OptDescr (Options -> Options)]
+options = [ Option ['a'] ["arbol"] (NoArg (\opts -> opts {optArbol = True})) "Muestra el AST luego de haber realizado el cálculo de escapes"
+            , Option ['e'] ["escapada"] (NoArg (\opts -> opts {optDebEscap = True})) "Stepper escapadas"]
+
+compilerOptions :: [String] -> IO (Options, [String])
+compilerOptions argv = case getOpt Permute options argv of
+                        (o,n,[]) -> return (foldl (flip id) defaultOptions o, n)
+                        (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+    where
+        header = "Se usa: tiger fileName [OPTIONS] "
+
+showExp :: Exp -> IO ()
+showExp e = do
+    putStrLn "Mostramos el AST (PP Gracias a Emilio Lopez Junior)"
+    putStrLn $ renderExp e
+
+calculoEscapadas :: Exp -> Options -> IO (Maybe Exp)
+calculoEscapadas rawAST opt = 
+                if optDebEscap opt then
+                    case (debbugEnv rawAST) of
+                    (Left errEsc) -> do
+                        putStrLn "Error en el calculo de variables escapadas:"
+                        print errEsc
+                        return Nothing
+                    (Right (exp,envs)) -> do
+                        putStrLn "Stepper MODE!!! Bienvenidos a la fiesta de las variables escapadas"
+                        mapM_ ((\str -> putStrLn str >> putStrLn "-------") . show) (reverse (e envs))
+                        putStrLn "yes!!!"
+                        return (Just exp)
+                else
+                    case (calcularEEsc rawAST) of
+                        (Left errEsc) -> do
+                            putStrLn "Error en el calculo de variables escapadas:"
+                            print errEsc 
+                            return Nothing
+                        (Right escap) -> do
+                            when (optArbol opt) (showExp escap)
+                            (putStrLn "yes!!!")
+                            return $ Just escap
+
+main = do
+    s:opts <- Env.getArgs
+    (opts', _) <- compilerOptions opts
+    sourceCode <- readFile s
+    either (\err -> error $ "Parser error..." ++ show err) 
+       (\ast -> do
+        east <- calculoEscapadas ast opts'
+        when (isNothing east) (error $ "Calculo escapadas")
+        print "Genial!") (runParser expression () s sourceCode)

haskell1/TigerParser.hs

+module TigerParser where
+
+import Text.Parsec
+import Text.Parsec.String (Parser)
+
+import qualified Text.Parsec.Token as Tok
+import qualified Text.Parsec.Expr as Ex
+
+import Data.Text hiding (map)
+
+import TigerAbs
+import TigerLexer
+import TigerSymbol
+
+binary s f assoc ln = Ex.Infix (do
+                        reservedOp s 
+                        return (\e1 e2 -> OpExp e1 f e2 ln)) assoc
+
+-- tthen e2 ln = Ex.Infix (
+--             do