Initial commit 2.

EDA/Arbus.hs

@@ -0,0 +1,63 @@
+-- | Módulo de implementación del tipo abstracto de datos árbol de búsqueda.
+module EDA.Arbus (
+	Arbus(ArbusVacio),
+	inserta,
+	consulta,
+	esta,
+	esVacio
+) where
+
+-- | 'Arbus' es un árbol de búsqueda con clave y valor.
+--
+--    Los elementos de tipo 'a' se denominarán «claves» y los del tipo 'b' «valores».
+--    El tipo 'a' ha de ser ordenable (ser instancia de la clase 'Ord').
+--
+--    Se ha omitido la operación de borrado.
+data Arbus a b =
+	-- | Árbol de búsqueda vacío.
+	ArbusVacio |
+	-- | Construye un árbol de búsqueda a partir de unos hijos, una clave y un valor.
+	Nodo (Arbus a b) a b (Arbus a b)
+
+-- | Inserta un elemento en el árbol de búsqueda.
+inserta :: (Ord a) => a -> b -> Arbus a b -> Arbus a b
+inserta c v ArbusVacio 		= Nodo ArbusVacio c v ArbusVacio
+inserta c v (Nodo iz c' v' dr)
+	| c == c'		= Nodo iz c v dr
+	| c < c'		= Nodo (inserta c v iz) c' v' dr
+	| otherwise		= Nodo iz c' v' (inserta c v dr)
+
+-- | Consulta el valor de una clave.
+consulta :: (Ord a) => a -> Arbus a b -> Maybe b
+consulta _ ArbusVacio	= Nothing
+consulta c (Nodo iz c' v dr)
+	| c == c'	= Just v
+	| c < c'	= consulta c iz
+	| otherwise	= consulta c dr
+
+-- | Comprueba si una clave está en el árbol de búsqueda.
+esta :: (Ord a) => a -> Arbus a b -> Bool
+esta _ ArbusVacio 	= False
+esta x (Nodo iz c _ dr)
+	| x == c	= True
+	| x < c		= esta x iz
+	| otherwise	= esta x dr
+
+-- | Comprueba si el árbol es vacío.
+esVacio :: Arbus a b -> Bool
+esVacio ArbusVacio	= True
+esVacio _		= False
+
+-- | Obtiene el recorrido en inorden del árbol, que se corresponde con
+--   la lista de pares clave valor ordenada por clave.
+inorden :: Arbus a b -> [(a, b)]
+inorden ArbusVacio = []
+inorden (Nodo iz c v dr) = inorden iz ++ (c, v):inorden dr
+
+-- Igualdad por comparación de inórdenes
+instance (Eq a, Eq b) => Eq (Arbus a b) where
+	x == y = inorden x == inorden y
+
+-- Muestra la lista de pares en inorden.
+instance (Show a, Show b) => Show (Arbus a b) where
+	show arb = "Arbus " ++ show (inorden arb)

Main.lhs

@@ -0,0 +1,91 @@
+% Intérprete de Rec
+
+Para documentación general y sobre uso del programa véase la documentación
+adjunta separada.
+
+Detalles de implementación
+--------------------------
+
+El intérprete se ha dividido en diversos módulos que se encargan de distintas
+tareas, como generar el árbol sintáctico abstracto a partir de la sintaxis
+concreta o evaluar semánticamente dicho árbol.
+
+> import EDA.Arbus
+> import REC.Base
+> import REC.Sintaxis
+> import qualified REC.PasoValor as Valor
+> import qualified REC.PasoNombre as Nombre
+>
+> import System.Environment
+
+Para el análisis sintáctico se ha utilizado la biblioteca de Haskell
+*Parsec* (versión 3).
+
+> import Text.Parsec (parse)
+> import Text.Parsec.String (Parser)
+
+El estado viene representado por un árbol de búsqueda binario que asocia nombres
+de función a pares lista de variables-término, que es la representación escogida
+para las funciones de Rec.
+
+> -- | Estado del intérprete de Rec.
+> type EstadoRec = Arbus String FuncionRec
+
+Inicialmente no hay función alguna predefinida.
+
+> -- | Estado inicial
+> estadoInicial :: EstadoRec
+> estadoInicial = ArbusVacio
+
+> -- | Parseador de términos cerrados
+> tcerrado :: Parser ExpresionRec
+> tcerrado = termino []
+
+
+La función principal lee texto de la entrada estándar y muestra el resultado en
+la salida por defecto.
+
+> -- | Alias para el tipo de las funciones semánticas
+> type FnSemantica = Arbus String FuncionRec -> ExpresionRec -> Resultado
+>
+> -- | Función principal
+> main :: IO ()
+> main = do
+>	espec		<- getContents
+>	fn		<- averiguaFn getArgs
+>	mapM_ putStrLn (interpretaLinea fn estadoInicial $ lines espec)
+>
+> 	where	averiguaFn :: IO [String] -> IO FnSemantica
+>
+>		averiguaFn = fmap (\x -> if x then Nombre.valor else Valor.valor)
+>				. fmap (any (\arg -> arg == "-n"))
+
+El programa intentará interpretar cada línea en primer lugar como una declaración de
+función. En caso de error se intentará interpretar como término cerrado.
+
+> interpretaLinea :: FnSemantica -> EstadoRec -> [String] -> [String]
+> interpretaLinea _ _ []		= []
+> interpretaLinea fn st (x:xs) 	= either (\_ -> term:(interpretaLinea fn nst xs))
+>					 (\_ -> interpretaLinea fn nst xs) decl
+> 	where	decl	= parse declaracion "" x
+> 		term	= interpretaTermino fn st x
+> 		nst	= either (\_ -> st) (\(nombre, def) -> inserta nombre def st) decl
+
+Esta función analiza sintácticamente la expresión dada como un término cerrado
+y devuelve el resultado de evaluarla o un mensaje de error apropiado.
+ 
+> -- | Intenta parsear un término
+> interpretaTermino :: FnSemantica -> EstadoRec -> String -> String
+> interpretaTermino fn st exp = either (show) (evaluaTermino fn st) (parse tcerrado "" exp)
+
+Esta función evalúa semánticamente un término, mostrando el mensaje de error apropiado
+en caso de fallo.
+
+> -- | Evalúa (semánticamente) un término ya parseado y convierte la salida
+> evaluaTermino :: FnSemantica -> EstadoRec -> ExpresionRec -> String
+> evaluaTermino fn st exp = case (fn st exp) of
+> 	Valor v			-> show v
+> 	ENoVar id		-> "Error: variable desconocida «" ++ id ++ "»."
+> 	ENoFunc id		-> "Error: función desconocida «" ++ id ++ "»."
+> 	EAridad id ao ad	-> "Error: aridad incorrecta en la función «" ++
+>		id ++ "» (" ++ show ao ++ " en lugar de " ++ show ad ++ ")."

Makefile

@@ -0,0 +1,42 @@
+# Makefile para el intérprete de REC
+
+PANDOC	:= $(shell pandoc -v 2> /dev/null)
+FUENTES := $(shell find . -type f -name '*.hs' -or -name '*.lhs')
+
+.PHONY: info clean clean-doc doc
+
+# Compilar con GCH
+make:
+	ghc -O Main.lhs -fno-warn-tabs -o rec
+
+# Eliminar tabulaciones en los archivos fuente
+destab:
+	$(foreach f, ${FUENTES}, expand ${f} > ${f}.expanded; mv ${f}.expanded ${f};)
+
+# Generar la documentación a nivel de código (con Haddock)
+doc:
+	haddock -h --optghc=-fno-warn-tabs -o doc/ref Main.lhs -t "Ecuaciones recursivas - Lenguaje Rec"
+
+# Generar la documentación adjunta
+ifdef PANDOC
+info: Main.htm doc/manual.es.htm doc/manual.en.htm doc/manual.fr.htm
+
+else
+info:
+	$(error Se necesita Pandoc para generar la documentación)
+endif
+
+%.htm: %.md
+	pandoc --from=markdown -s --to=html5 $< -o $@
+
+%.htm: %.lhs
+	pandoc --from=markdown+lhs -s --to=html5 $< -o $@
+
+# Borrar archivos intermedios generados por GHC
+clean:
+	$(RM) REC/*.hi EDA/*.hi REC/*.o EDA/*.o Main.hi Main.o
+
+# Borra la documentación generada 
+clean-doc:
+	$(RM) -r doc/ref
+	$(RM) Main.htm doc/*.htm

REC/Base.hs

@@ -0,0 +1,76 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  REC.Base
+--
+-- Definiciones básicas de Rec.
+--
+-- Sintaxis abstracta y tipo del valor semántico.
+-- 
+-----------------------------------------------------------------------------
+
+module REC.Base (
+	ExpresionRec(..),
+	FuncionRec,
+	Resultado(..),
+	esValor
+) where
+
+-- | Representación abstracta de un término de Rec.
+data ExpresionRec =
+	Literal Integer |
+	Variable String |
+	Suma ExpresionRec ExpresionRec |
+	Resta ExpresionRec ExpresionRec |
+	Producto ExpresionRec ExpresionRec |
+	Condicional ExpresionRec ExpresionRec ExpresionRec |
+	Llamada String [ExpresionRec]
+	deriving (Show)
+
+-- | Definición de función del lenguaje Rec.
+--
+-- Es un par con la lista de nombres de variables y el
+-- término que constituye su definición.
+
+type FuncionRec = ([String], ExpresionRec)
+
+-- | Resultado de la evaluación de un término Rec.
+--
+-- Desglosa las posibles causas de error como sigue:
+data Resultado =
+	-- | Resultado correcto
+	Valor Integer |
+	-- | Referencia a una función desconocida
+	ENoFunc String |
+	-- | Referencia a una variable desconocida
+	ENoVar String |
+	-- | Llamada a función con una aridad diferente de la de su definición
+	-- (se indican por ese orden)
+	EAridad String Int Int
+	deriving (Show, Eq)
+
+-- | Aritmética numérica por comodidad.
+-- En caso de error prevalece el generado en el término más a la izquierda.
+instance Num Resultado where
+	(Valor n) + (Valor m)	= Valor (n + m)
+	(Valor _) + res		= res
+	res + _			= res
+
+	(Valor n) * (Valor m)	= Valor (n * m)
+	(Valor _) * res		= res
+	res * _			= res
+
+	abs (Valor n) 		= Valor (abs n)
+	abs res			= res
+
+	signum (Valor n)	= Valor (signum n)
+	signum _		= Valor 1
+
+	fromInteger n		= Valor n
+
+	negate (Valor n)	= Valor (negate n)
+	negate res		= res
+
+-- | Detecta si un resultado es correcto (es decir, no es un error)
+esValor :: Resultado -> Bool
+esValor (Valor _)	= True
+esValor	_		= False

REC/PasoNombre.hs

@@ -0,0 +1,63 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  REC.PasoNombre
+--
+-- Función semántica de paso por nombre.
+--
+-- La definición de la función semántica es prácticamente igual a la de paso
+-- por valor. Los errores de función desconocida en los parámetros que no
+-- lleguen a evaluarse pasarán desapercibidos.
+--
+-----------------------------------------------------------------------------
+
+module REC.PasoNombre (
+	valor
+) where
+
+import REC.Base
+import EDA.Arbus
+
+-- | Función semántica de paso por nombre,
+-- acorde a la definición del capítulo 9 de
+-- /Formal Semantics of Programming Languages/ de Glynn Winksel.
+
+valor	::	Arbus String FuncionRec 	-- ^ Entorno de funciones
+		-> ExpresionRec -> Resultado
+
+valor 		= evaluar ArbusVacio
+
+
+-- | Definición completa de la función semántica.
+
+evaluar ::	Arbus String Resultado		-- ^ Entorno de variables (a resultados)
+		-> Arbus String FuncionRec 	-- ^ Entorno de funciones
+		-> ExpresionRec -> Resultado
+
+evaluar _ _	(Literal m)		= Valor m
+evaluar vs fs	(Suma izq dr)		= evaluar vs fs izq + evaluar vs fs dr
+evaluar vs fs	(Resta izq dr)		= evaluar vs fs izq - evaluar vs fs dr
+evaluar vs fs	(Producto izq dr)	= evaluar vs fs izq * evaluar vs fs dr
+evaluar vs fs	(Condicional cn rt rf)
+	| not (esValor cond)		= cond
+	| cond == (Valor 0)		= evaluar vs fs rt
+	| otherwise			= evaluar vs fs rf
+	where cond = evaluar vs fs cn
+
+evaluar vs _	(Variable id)			= comoRes $ consulta id vs
+	where	comoRes (Just res)	= res
+		comoRes Nothing		= ENoVar id
+
+evaluar vs fs	(Llamada id ps)	= evaluarAux (consulta id fs)
+	where	evaluarAux :: Maybe FuncionRec -> Resultado
+
+		evaluarAux Nothing			= ENoFunc id
+		evaluarAux (Just (args, cuerpo))
+			| length ps == length args	= evaluar nuevoVar fs cuerpo
+			| otherwise			= EAridad id (length ps) (length args)
+
+			where nuevoVar = evParams args (map (evaluar vs fs) ps)
+
+		evParams  :: [String] -> [Resultado] -> Arbus String Resultado
+
+		evParams (n:ns) (r:rs)	= inserta n r (evParams ns rs)
+		evParams _ []		= ArbusVacio