Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
refactor code into separate files; fix toJs tabbing
  • Loading branch information
sinelaw committed Sep 9, 2014
1 parent 0127356 commit f829657
Show file tree
Hide file tree
Showing 5 changed files with 130 additions and 75 deletions.
28 changes: 28 additions & 0 deletions Demo.hs
@@ -0,0 +1,28 @@
module Test where

import Control.Monad.State(runState)
import Data.Maybe(fromJust)

import Infer
import Pretty
import Types

-- ------------------------------------------------------------------------

ex expr = Expr expr ()

e1 = ex $ LitFunc ["arg"] ["vari"]
$ [ex $ Var "vari"
, ex $ Assign (ex $ Var "vari") (ex $ LitObject [("amount", ex $ LitNumber 123)])
, ex $ Assign (ex $ Property (ex $ Var "vari") "amount") (ex $ LitNumber 0)
-- , ex $ Assign (ex $ Var "vari") (ex $ LitString "ma?")
, ex $ Return (ex $ LitArray [])
, ex $ Return (ex $ LitArray [ex $ LitObject [("bazooka", ex $ Var "arg"), ("number", ex $ Var "vari")]])]
--e1 = ex $ LitFunc ["arg"] ["vari"] []

t1 = inferType Global e1
s1 = runState t1 emptyScope
s1doc = toJsDoc . fromJust . getExprType $ fst s1

e2 = ex $ Property (ex $ Index (ex $ Call e1 [(ex $ LitString "abc")]) (ex $ LitNumber 2)) "number"
s2 = runState (inferType Global e2) emptyScope
76 changes: 1 addition & 75 deletions Test.hs → Infer.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE DeriveGeneric, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}

module Test where
module Infer where

import Types

Expand Down Expand Up @@ -39,72 +39,20 @@ data Body expr = LitBoolean Bool



instance (Out a) => Out (Body a)

data Expr a = Expr (Body (Expr a)) a
deriving (Show, Eq, Generic)


instance (Out a) => Out (Expr a)

commafy :: [String] -> String
commafy [] = []
commafy (x:[]) = x
commafy (x:xs) = x ++ ", " ++ (commafy xs)

toJs :: Expr a -> String
toJs (Expr body _) =
case body of
Assign target src -> (toJs target) ++ " = " ++ (toJs src)
Call callee args -> (toJs callee) ++ "(" ++ (commafy $ map toJs args) ++ ")"
Index arr idx -> (toJs arr) ++ "[" ++ (toJs idx) ++ "]"
LitArray xs -> "[ " ++ (commafy $ map toJs xs) ++ " ]"
LitBoolean x -> if x then "true" else "false"
LitFunc args varNames exprs -> "function (" ++ argsJs ++ ") " ++ block
where argsJs = commafy $ args
block = "{\n" ++ vars' ++ "\n" ++ statements ++ " }\n"
statements = (concat $ map (++ ";\n") $ map toJs exprs)
vars' = "var " ++ commafy varNames ++ ";"
LitNumber x -> if (fromIntegral truncated) == x
then show $ truncated
else show x
where truncated = truncate x :: Integer
LitObject xs -> "{ " ++ (commafy $ map (\(name, val) -> name ++ ": " ++ (toJs val)) xs) ++ " }"
LitRegex regex -> "/" ++ regex ++ "/" -- todo correctly
LitString s -> "'" ++ s ++ "'" -- todo escape
Property obj name -> (toJs obj) ++ "." ++ name
Return expr -> "return " ++ toJs expr
Var name -> name


toJsDoc :: JSType -> String
toJsDoc JSBoolean = "boolean"
toJsDoc JSNumber = "number"
toJsDoc JSString = "string"
toJsDoc JSRegex = "regex"
toJsDoc (JSFunc args res) = "function(" ++ (commafy . map toJsDoc $ args) ++ ") : " ++ (toJsDoc res)
toJsDoc (JSArray elem') = "[" ++ toJsDoc elem' ++ "]"
toJsDoc (JSObject props) = "{ " ++ (commafy . map showProp $ props) ++ " }"
where showProp (name, t) = (show name) ++ ": " ++ (toJsDoc t)
toJsDoc (JSTVar name) = toStrName name
where toStrName x = letters!!(x `mod` numLetters):[] ++ (suffix x)
letters = ['a'..'z']
numLetters = length letters
suffix x = if 0 < x `div` numLetters
then show (x `div` numLetters)
else ""


data TypeError = TypeError String
deriving (Show, Eq, Generic)

instance Out TypeError


data VarScope = Global | VarScope { parent :: VarScope, vars :: [(String, JSType)] }
deriving (Show, Eq, Generic)

instance Out VarScope

instance (Out k, Out v) => Out (Map.Map k v) where
doc m = doc $ Map.assocs m
Expand All @@ -113,20 +61,17 @@ instance (Out k, Out v) => Out (Map.Map k v) where
data TypeScope = TypeScope { tVars :: TSubst JSConsType, maxNum :: Int }
deriving (Show, Eq, Generic)

instance Out TypeScope

data FuncScope = FuncScope { funcVars :: [(String, JSType)]
, returnType :: JSType }
deriving (Show, Eq, Generic)

instance Out FuncScope


data Scope = Scope { typeScope :: TypeScope
, funcScope :: Maybe FuncScope }
deriving (Show, Eq, Generic)

instance Out Scope

getVarType :: VarScope -> String -> Maybe JSType
getVarType Global _ = Nothing
Expand Down Expand Up @@ -401,22 +346,3 @@ inferObjectType varScope props =
$ map (fromJust . getExprType) inferredProps)
$ newBody

-- ------------------------------------------------------------------------

ex expr = Expr expr ()

e1 = ex $ LitFunc ["arg"] ["vari"]
$ [ex $ Var "vari"
, ex $ Assign (ex $ Var "vari") (ex $ LitObject [("amount", ex $ LitNumber 123)])
, ex $ Assign (ex $ Property (ex $ Var "vari") "amount") (ex $ LitNumber 0)
-- , ex $ Assign (ex $ Var "vari") (ex $ LitString "ma?")
, ex $ Return (ex $ LitArray [])
, ex $ Return (ex $ LitArray [ex $ LitObject [("bazooka", ex $ Var "arg"), ("number", ex $ Var "vari")]])]
--e1 = ex $ LitFunc ["arg"] ["vari"] []

t1 = inferType Global e1
s1 = runState t1 emptyScope
s1doc = toJsDoc . fromJust . getExprType $ fst s1

e2 = ex $ Property (ex $ Index (ex $ Call e1 [(ex $ LitString "abc")]) (ex $ LitNumber 2)) "number"
s2 = runState (inferType Global e2) emptyScope
75 changes: 75 additions & 0 deletions Pretty.hs
@@ -0,0 +1,75 @@
module Pretty where

import Data.List(intersperse)
import Text.PrettyPrint.GenericPretty(Generic, Out(..), pp)


import Types
import Infer



instance (Out a) => Out (Body a)
instance (Out a) => Out (Expr a)
instance Out TypeError
instance Out VarScope
instance Out TypeScope
instance Out FuncScope
instance Out Scope


commafy :: [String] -> String
commafy [] = []
commafy (x:[]) = x
commafy (x:xs) = x ++ ", " ++ (commafy xs)

toJs :: Expr a -> String
toJs = toJs' 0

makeTab :: Int -> String
makeTab tabAmount = "\n" ++ (concat $ replicate tabAmount " " )

toJs' :: Int -> Expr a -> String
toJs' tabAmount (Expr body _) = let tab = makeTab tabAmount in
case body of
Assign target src -> (toJs'' target) ++ " = " ++ (toJs'' src)
Call callee args -> (toJs'' callee) ++ "(" ++ (commafy $ map toJs'' args) ++ ")"
Index arr idx -> (toJs'' arr) ++ "[" ++ (toJs'' idx) ++ "]"
LitArray xs -> "[" ++ (commafy $ map toJs'' xs) ++ "]"
LitBoolean x -> if x then "true" else "false"
LitFunc args varNames exprs -> "function (" ++ argsJs ++ ") {" ++ block ++ tab ++ "}"
where argsJs = commafy $ args
block = concat $ intersperse tab' ["", vars', "", statements]
statements = (concat $ map (++ ";" ++ tab') $ map toJs'' exprs)
vars' = "var " ++ commafy varNames ++ ";"
tab' = makeTab $ tabAmount + 1
LitNumber x -> if (fromIntegral truncated) == x
then show $ truncated
else show x
where truncated = truncate x :: Integer
LitObject xs -> "{ " ++ (commafy $ map (\(name, val) -> name ++ ": " ++ (toJs'' val)) xs) ++ " }"
LitRegex regex -> "/" ++ regex ++ "/" -- todo correctly
LitString s -> "'" ++ s ++ "'" -- todo escape
Property obj name -> (toJs'' obj) ++ "." ++ name
Return expr -> "return " ++ toJs'' expr
Var name -> name
where toJs'' = toJs' (tabAmount + 1)


toJsDoc :: JSType -> String
toJsDoc JSBoolean = "boolean"
toJsDoc JSNumber = "number"
toJsDoc JSString = "string"
toJsDoc JSRegex = "regex"
toJsDoc (JSFunc args res) = "function(" ++ (commafy . map toJsDoc $ args) ++ ") : " ++ (toJsDoc res)
toJsDoc (JSArray elem') = "[" ++ toJsDoc elem' ++ "]"
toJsDoc (JSObject props) = "{ " ++ (commafy . map showProp $ props) ++ " }"
where showProp (name, t) = (show name) ++ ": " ++ (toJsDoc t)
toJsDoc (JSTVar name) = toStrName name
where toStrName x = letters!!(x `mod` numLetters):[] ++ (suffix x)
letters = ['a'..'z']
numLetters = length letters
suffix x = if 0 < x `div` numLetters
then show (x `div` numLetters)
else ""

2 changes: 2 additions & 0 deletions Setup.hs
@@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain
24 changes: 24 additions & 0 deletions jss.cabal
@@ -0,0 +1,24 @@
-- Initial jss.cabal generated by cabal init. For further documentation,
-- see http://haskell.org/cabal/users-guide/

name: jss
version: 0.1.0.0
-- synopsis:
-- description:
-- license:
license-file: LICENSE
author: Noam Lewis
maintainer: noam.lewis@elastifile.com
-- copyright:
-- category:
build-type: Simple
extra-source-files: README.md
cabal-version: >=1.10

library
exposed-modules: Infer, Pretty, Types
-- other-modules:
other-extensions: DeriveGeneric
build-depends: base >=4.7 && <4.8, GenericPretty, mtl, containers
--hs-source-dirs:
default-language: Haskell2010

0 comments on commit f829657

Please sign in to comment.