{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Language.Del.AST where
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import Language.Del.TypeTable
import Network.HTTP.Req
data DelNum
= DelInt Integer
| DelFloat Double
deriving (Show, Eq)
type Name = T.Text
data Expr
= Add [Expr]
| Mul [Expr]
| Sub Expr Expr
| Div Expr Expr
| Pow Expr Expr
| Lt Expr Expr
| Gt Expr Expr
| LtE Expr Expr
| GtE Expr Expr
| Negate Expr
| Subscript Expr T.Text
| Apply Expr [Expr]
| NativeCall T.Text [Expr]
| Id Name
| ScopedId Name Name
| Number DelNum
| Boolean Bool
| Let Name Expr Expr
| If Expr Expr Expr
deriving Eq
rootKey :: T.Text
rootKey = "root"
data SourceUrl = HttpSource (Url 'Http)
| HttpsSource (Url 'Https)
deriving Eq
type Source = Either Name SourceUrl
data Def = Def T.Text Type [(T.Text, Type)] Expr deriving Eq
data Import = Import Source T.Text
instance Show Def where
show (Def n ret args body) = concat [
"(", T.unpack n, ":", (show ret), " ",
unwords $ map (\(a, t) -> T.unpack a ++ ":" ++ show t) args,
") -> ", show body]
instance Show Import where
show (Import (Left name) alias) = concat [
"(#import ", T.unpack name, " -> ", T.unpack alias, ")"]
show (Import (Right url) alias) = concat [
"(#import ", show url, " -> ", T.unpack alias, ")"]
-- Programs are maps from bound name to the form that binds it
data AST = AST (Map.Map T.Text Def) [Import]
instance Show AST where
show (AST m i) = imps ++ "\n" ++ defs
where defs = unlines . map (show . snd) . Map.toAscList $ m
imps = unlines $ map show i
getAstMap :: AST -> Map.Map T.Text Def
getAstMap (AST m _) = m
makeIndent :: Integer -> String
makeIndent 0 = ""
makeIndent n = " " ++ makeIndent (n - 1)
showExprList :: String -> [Expr] -> String
showExprList h xs = concat ["(", h, " ", unwords $ map show xs, ")"]
instance Show Expr where
show (Add xs) = showExprList "+" xs
show (Mul xs) = showExprList "*" xs
show (Sub x1 x2) = showExprList "-" [x1, x2]
show (Div x1 x2) = showExprList "/" [x1, x2]
show (Pow x1 x2) = showExprList "^" [x1, x2]
show (Gt x1 x2) = showExprList ">" [x1, x2]
show (Lt x1 x2) = showExprList "<" [x1, x2]
show (GtE x1 x2) = showExprList ">=" [x1, x2]
show (LtE x1 x2) = showExprList "<=" [x1, x2]
show (Negate x) = "~" ++ show x
show (Subscript e sub) = show e ++ "_" ++ T.unpack sub
show (Apply h xs) = showExprList (show h) xs
show (Id n) = T.unpack n
show (ScopedId p n) = T.unpack p ++ "." ++ T.unpack n
show (Number (DelInt i)) = show i
show (Number (DelFloat f)) = show f
show (Let n e b) = concat ["(let (", T.unpack n, " ", show e, ") ", show b]
show (Boolean b) = show b
show (If c t f) = concat ["(if ", show c, " ", show t, " ", show f]
show (NativeCall n xs) = showExprList ("$" ++ T.unpack n) xs
instance Show SourceUrl where
show (HttpSource u) = show u
show (HttpsSource u) = show u
canonicalId :: Expr -> Expr
canonicalId (ScopedId p n) = Id $ T.concat [p, ".", n]
canonicalId e@(Id _) = e
canonicalId _ = undefined
-- Converts a list of Del numbers to floats if any elements in the list are
-- floats; otherwise, keeps them as integers
promote :: [DelNum] -> [DelNum]
promote ns = if anyFloats ns then map toFloat ns else ns
toFloat :: DelNum -> DelNum
toFloat (DelInt i) = DelFloat . fromIntegral $ i
toFloat float = float
anyFloats :: [DelNum] -> Bool
anyFloats ((DelFloat _):_) = True
anyFloats (_:xs) = anyFloats xs
anyFloats [] = False
sumFloats :: DelNum -> DelNum -> DelNum
sumFloats (DelFloat f1) (DelFloat f2) = DelFloat $ f1 + f2
sumFloats _ _ = undefined
sumInts :: DelNum -> DelNum -> DelNum
sumInts (DelInt f1) (DelInt f2) = DelInt $ f1 + f2
sumInts _ _ = undefined
prodFloats :: DelNum -> DelNum -> DelNum
prodFloats (DelFloat f1) (DelFloat f2) = DelFloat $ f1 * f2
prodFloats _ _ = undefined
prodInts :: DelNum -> DelNum -> DelNum
prodInts (DelInt f1) (DelInt f2) = DelInt $ f1 * f2
prodInts _ _ = undefined
wrapUnary :: (forall n. Num n => n -> n) -> DelNum -> DelNum
wrapUnary func (DelInt i) = DelInt $ func i
wrapUnary func (DelFloat f) = DelFloat $ func f
getFloat :: DelNum -> Double
getFloat (DelFloat f) = f
getFloat (DelInt i) = fromIntegral i
instance Num DelNum where
a + b = if anyFloats [a, b]
then sumFloats (toFloat a) (toFloat b)
else sumInts a b
a * b = if anyFloats [a, b]
then prodFloats (toFloat a) (toFloat b)
else prodInts a b
abs = wrapUnary abs
signum = wrapUnary signum
negate = wrapUnary negate
fromInteger = DelInt
instance Fractional DelNum where
a / b = DelFloat $ getFloat a / getFloat b
fromRational = DelFloat . fromRational
pow :: DelNum -> DelNum -> DelNum
pow (DelInt b) (DelInt p) = DelInt $ b ^ p
pow (DelFloat b) (DelInt p) = DelFloat $ b ^ p
pow (DelInt b) (DelFloat p) = DelFloat $ (fromInteger b) ** p
pow (DelFloat b) (DelFloat p) = DelFloat $ b ** p