├── ChangeLog.md ├── LICENSE ├── README.md ├── default.nix ├── docs ├── all.min.js └── index.html ├── fvg.cabal ├── site └── Main.hs ├── src ├── AbsSyn.hs ├── Interpreter.hs ├── Parser.hs └── TypeChecker.hs └── tests ├── Case1.fvg ├── Case1.out ├── Circle.fvg ├── Circle.out ├── Circle.png ├── Enumerate.fvg ├── Enumerate.out ├── HOF.fvg ├── HOF.out ├── HOF.png ├── HelloWorld.fvg ├── HelloWorld.out ├── HelloWorld.png ├── Let1.fvg ├── Let1.out ├── Let2.fvg ├── Lists.fvg ├── Lists.out ├── Lists.png ├── Poly1.fvg ├── Poly1.out ├── Poly2.fvg ├── Poly2.out ├── Poly3.fvg ├── Poly3.out ├── Poly4.fvg ├── Poly5.fvg └── runtests.hs /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for fvg 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, David Himmelstrup 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Greg Hale nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Functional Vector Graphics 2 | 3 | A compiler and interpreter for a small language of vector graphics. Play with the language at [https://lemmih.github.io/fvg](https://lemmih.github.io/fvg). The language supports ADTs, pattern matching, HM type inference, and Svg literal values. 4 | 5 | # Test suite 6 | 7 | From the `tests/` directory, run: `runhaskell -i../src runtests.hs` 8 | 9 | To run a single test: `runhaskell -i../src runtest.sh [file].fvg` 10 | The output will be stored in `[file].out`. 11 | 12 | # Frontend 13 | 14 | Clone [reflex-platform](https://github.com/reflex-frp/reflex-platform) 15 | 16 | Then run `reflex-platform/work-on ghcjs ./. --command "cabal configure --ghcjs -fSite && cabal build"` 17 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, containers, file-embed, ghcjs-dom, lens, mtl 2 | , parsec, reflex, reflex-dom, stdenv, string-qq, text 3 | }: 4 | mkDerivation { 5 | pname = "fvg"; 6 | version = "0.1.0.0"; 7 | src = ./.; 8 | configureFlags = [ "-fsite" ]; 9 | isLibrary = true; 10 | isExecutable = true; 11 | libraryHaskellDepends = [ 12 | base containers file-embed mtl parsec reflex reflex-dom 13 | ]; 14 | executableHaskellDepends = [ 15 | base containers file-embed ghcjs-dom lens reflex-dom string-qq text 16 | ]; 17 | license = stdenv.lib.licenses.bsd3; 18 | } 19 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | -------------------------------------------------------------------------------- /fvg.cabal: -------------------------------------------------------------------------------- 1 | -- Initial fvg.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: fvg 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: David Himmelstrup 11 | maintainer: lemmih@gmail.com 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | extra-source-files: ChangeLog.md, README.md 16 | cabal-version: >=1.10 17 | 18 | flag Site 19 | description: Enable frontend 20 | default: False 21 | 22 | library 23 | exposed-modules: AbsSyn, Interpreter, Parser, TypeChecker 24 | -- other-modules: 25 | other-extensions: TupleSections 26 | build-depends: base >=4.9 && <4.10 27 | , containers >=0.5 && <0.6 28 | , mtl 29 | , parsec 30 | hs-source-dirs: src 31 | default-language: Haskell2010 32 | 33 | executable site 34 | if flag(Site) 35 | buildable: True 36 | else 37 | buildable: False 38 | main-is: Main.hs 39 | hs-source-dirs: site 40 | default-language: Haskell2010 41 | build-depends: base 42 | , containers 43 | , file-embed 44 | , fvg 45 | , ghcjs-dom 46 | , lens 47 | , reflex-dom 48 | , string-qq 49 | , text 50 | -------------------------------------------------------------------------------- /site/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE RecursiveDo #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Main where 7 | 8 | import Control.Lens 9 | import Control.Monad 10 | import Control.Monad.IO.Class (liftIO) 11 | import qualified Control.Exception as E 12 | import Data.Bool (bool) 13 | import Data.Either (isLeft) 14 | import qualified Data.Map as Map 15 | import Data.Maybe (catMaybes) 16 | import Data.Monoid ((<>)) 17 | import qualified Data.Text.Encoding as T 18 | import Reflex.Dom 19 | import Data.FileEmbed 20 | import qualified Data.Text as T 21 | import GHCJS.DOM.Types hiding (Event(..), Text(..)) 22 | import Data.String.QQ 23 | 24 | import AbsSyn 25 | import Interpreter 26 | import Parser 27 | import TypeChecker 28 | 29 | 30 | main :: IO () 31 | main = mainWidgetWithHead header $ divClass "content" $ do 32 | menu 33 | rec divClass "widget" $ do 34 | c <- codeBox ex 35 | fvgView c 36 | ex <- examplesPicker 37 | blank 38 | footer 39 | 40 | codeBox 41 | :: MonadWidget t m 42 | => Event t T.Text 43 | -> m (Dynamic t (Either E.SomeException Expr)) 44 | codeBox setText = divClass "code-box" $ do 45 | pb <- getPostBuild 46 | t <- fmap value $ 47 | textArea $ def 48 | & textAreaConfig_attributes .~ 49 | constDyn ("style" =: "width:500px;height:500px;") 50 | & textAreaConfig_setValue .~ setText 51 | & textAreaConfig_initialValue .~ code0 52 | 53 | let evalTime = leftmost [tag (current t) pb, updated t] 54 | evals <- performEvent $ ffor evalTime $ \code -> 55 | liftJSM . liftIO . E.try . E.evaluate . runScript $ T.unpack code 56 | res <- holdDyn (Left $ E.SomeException (error "e" :: E.IOException)) evals 57 | divClass "error-message" $ 58 | dynText $ bool "" "There is a problem" . isLeft <$> res 59 | return res 60 | 61 | 62 | fvgView 63 | :: MonadWidget t m 64 | => Dynamic t (Either E.SomeException Expr) 65 | -> m () 66 | fvgView e = do 67 | srcdoc <- holdDyn "

Waiting

" 68 | (T.pack . show <$> fmapMaybe hush (updated e)) 69 | elDynAttr "iframe" (iframeAttrs <$> srcdoc) blank 70 | where iframeAttrs sd = "width" =: "500" 71 | <> "height" =: "500" 72 | <> "srcdoc" =: sd 73 | 74 | examplesPicker :: MonadWidget t m => m (Event t T.Text) 75 | examplesPicker = do 76 | dd <- dropdown "" (constDyn $ ("" =: "Examples") <> Map.fromList examples) def 77 | return $ _dropdown_change dd 78 | 79 | hush :: Either e a -> Maybe a 80 | hush (Left _) = Nothing 81 | hush (Right a) = Just a 82 | 83 | 84 | --Toggle the bool to work from an external stylesheet 85 | -- (much faster, if all you want to do is tweak the 86 | -- page style) 87 | header :: MonadWidget t m => m () 88 | header = if True 89 | then el "style" $ text (T.pack style) 90 | else elAttr "link" ("rel" =: "stylesheet" <> 91 | "href" =: "style.css" <> 92 | "type" =: "text/css" 93 | ) blank 94 | 95 | 96 | menu :: MonadWidget t m => m () 97 | menu = divClass "menu" $ do 98 | text "fvg" 99 | elAttr "a" ("href" =: "https://github.com/lemmih/fvg") 100 | -- (elAttr "img" ("src" =: "where's a link to octocat?") blank) 101 | (text "Github") 102 | 103 | footer :: MonadWidget t m => m () 104 | footer = blank 105 | 106 | examples :: [(T.Text, T.Text)] 107 | examples = filt $ $(embedDir "tests") 108 | where 109 | filt xs = do 110 | (fn, f) <- xs 111 | let ft = T.pack fn 112 | guard $ ".fvg" `T.isSuffixOf` ft 113 | return (T.decodeUtf8 f, ft) 114 | 115 | code0 :: T.Text 116 | code0 = T.unlines [ 117 | "data Bool = True | False" 118 | , "" 119 | ,"main : Int" 120 | ,"main =" 121 | ," case True of" 122 | ," True -> 1" 123 | ," False -> 0" 124 | ] 125 | 126 | style :: String 127 | style = [s| 128 | .menu { 129 | display: flex; 130 | flex-direction: row; 131 | justify-content: space-between; 132 | font-size: 16pt; 133 | padding-bottom: 20px; 134 | } 135 | 136 | .content { 137 | display: flex; 138 | flex-direction: column; 139 | padding: 10px; 140 | } 141 | 142 | .widget { 143 | display: flex; 144 | flex-direction: row; 145 | padding-bottom: 20px; 146 | } 147 | 148 | .code-box { 149 | position: relative; 150 | } 151 | 152 | .error-message { 153 | position: absolute; 154 | top: 20px; 155 | right: 20px; 156 | color: hsla(0, 50%, 50%, 1); 157 | } 158 | 159 | a { 160 | text-decoration: none; 161 | color: hsl(234, 35%, 53%); 162 | } 163 | 164 | html { 165 | width: 100%; 166 | height: 100%; 167 | padding: 0px; 168 | margin: 0px; 169 | } 170 | 171 | body { 172 | background-color: hsl(0,0%, 95%); 173 | font-family: Helvetica; 174 | display: flex; 175 | flex-direction: column; 176 | width: 100%; 177 | height: 100%; 178 | padding: 0px; 179 | margin: 0px; 180 | } 181 | 182 | textarea { 183 | /* background-color: rgba(0,0,0,0); */ 184 | background-color: hsl(0, 0%, 75%); 185 | color: hsl(240, 53%, 28%); 186 | border: none; 187 | resize: none; 188 | outline: none; 189 | font-family: "Lucida Console", Monaco, monospace; 190 | padding: 0px; 191 | padding-left: 10px; 192 | } 193 | 194 | iframe { 195 | border-style: solid; 196 | border: 0px; 197 | border-left: thick double rgba(0,0,0,0.25); 198 | } 199 | 200 | select { 201 | width: 400px; 202 | } 203 | |] 204 | -------------------------------------------------------------------------------- /src/AbsSyn.hs: -------------------------------------------------------------------------------- 1 | module AbsSyn where 2 | 3 | import Data.List 4 | 5 | type TyVar = String 6 | type TypeName = String 7 | type FnName = String 8 | 9 | data Module = Module 10 | { modDataDecls :: [DataDecl] 11 | , modFunDecls :: [FunDecl] 12 | } deriving (Show) 13 | 14 | data DataDecl = DataDecl 15 | { ddName :: TypeName 16 | , ddTypeVariables :: [TyVar] 17 | , ddConstructors :: [DataConstructor] 18 | } deriving (Show) 19 | 20 | data DataConstructor = DataConstructor 21 | { dcName :: TypeName 22 | , dcFields :: [Type] 23 | } deriving (Show) 24 | 25 | data Type 26 | = TyVar TyVar 27 | | TyCon TypeName 28 | | TyFun Type Type 29 | | TyApp Type Type 30 | deriving (Show, Eq) 31 | 32 | data FunDecl = FunDecl 33 | { fdName :: FnName 34 | , fdType :: Type 35 | , fdArguments :: [String] 36 | , fdBody :: Expr 37 | } deriving (Show) 38 | 39 | data Expr 40 | = LitChar Char 41 | | LitInt Integer 42 | | LitFloat Double 43 | | LitString FvgString 44 | | XmlNode String [(String,FvgString)] [Expr] 45 | | Let String Expr Expr 46 | | App Expr Expr 47 | | Var String 48 | | Con String 49 | | Lam String Expr 50 | | Case Expr [Alt] 51 | 52 | arrowPrecedence = 1 53 | appPrecedence = 2 54 | 55 | parensIf False x = x 56 | parensIf True x = showChar '(' . x . showChar ')' 57 | 58 | instance Show Expr where 59 | showsPrec p expr = 60 | case expr of 61 | LitChar c -> showsPrec p c 62 | LitInt i -> showsPrec p i 63 | LitFloat f -> showsPrec p f 64 | LitString s -> showString (showSvgString s) 65 | XmlNode tag props exprs -> parensIf (p > 0) $ 66 | showString " <" . showString tag . showChar ' ' . 67 | showProps props . showString ">" . 68 | flip (foldr id) ({-intersperse (showString "; ")-} (map shows exprs)) . 69 | showString (" ") 70 | Let lhs rhs body -> 71 | showString "let " . showString lhs . showString " = " . shows rhs . showString " in " . shows body 72 | App a b -> parensIf (p > arrowPrecedence) $ 73 | showsPrec arrowPrecedence a . showChar ' ' . showsPrec appPrecedence b 74 | Var s -> showString s 75 | Con c -> showString c 76 | Lam bind body -> parensIf (p > 0) $ 77 | showChar '\\' . showString bind . showString " -> " . shows body 78 | 79 | showProps [] = id 80 | showProps ((k,v):xs) = showString k . showChar '=' . shows (showSvgString v) . showChar ' ' . showProps xs 81 | 82 | showSvgString = concatMap toString 83 | where 84 | toString (TextBlock txt) = txt 85 | toString (VariableBlock var) = "{{" ++ var ++ "}}" 86 | toString ExprBlock{} = "{{__EXPR__}}" 87 | 88 | data Alt = Alt Pattern Expr deriving (Show) 89 | 90 | data Pattern 91 | = PatternChar Char 92 | | PatternInt Integer 93 | | PatternNode String [String] 94 | deriving (Show) 95 | 96 | -- "string {{variable}} more string" 97 | type FvgString = [StringBlock] 98 | data StringBlock = TextBlock String | VariableBlock String | ExprBlock Expr 99 | deriving (Show) 100 | -------------------------------------------------------------------------------- /src/Interpreter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | module Interpreter (runScript) where 3 | 4 | import Control.Monad.Reader 5 | import Data.Map (Map) 6 | import qualified Data.Map as Map 7 | import Debug.Trace 8 | import Text.Parsec 9 | 10 | import AbsSyn 11 | import Parser 12 | import TypeChecker 13 | 14 | runScript :: String -> Expr 15 | runScript inp = evaluate (typecheck (runParse (parseModule <* eof) inp)) 16 | 17 | evaluate :: Module -> Expr 18 | evaluate m = runReader (evalFunction "main") env 19 | where 20 | env = Map.fromList 21 | [ (fdName fun, fdLambda fun) | fun <- modFunDecls m ] 22 | 23 | fdLambda :: FunDecl -> Expr 24 | fdLambda fd = foldr Lam (fdBody fd) (fdArguments fd) 25 | 26 | type Eval a = Reader (Map String Expr) a 27 | 28 | require :: (Ord k, Show k) => k -> Map k v -> v 29 | require k m = 30 | case Map.lookup k m of 31 | Just v -> v 32 | Nothing -> error $ "Key not found: " ++ show (k, Map.keys m) 33 | 34 | evalFunction :: String -> Eval Expr 35 | evalFunction name = evalExpr =<< asks (require name) 36 | 37 | substMany :: [(String, Expr)] -> Expr -> Expr 38 | substMany [] = id 39 | substMany ((k,v):xs) = substMany xs . subst k v 40 | 41 | subst :: String -> Expr -> Expr -> Expr 42 | subst key value expr = 43 | case expr of 44 | LitChar{} -> expr 45 | LitInt{} -> expr 46 | LitFloat{} -> expr 47 | LitString txt -> LitString $ map substBlock txt 48 | XmlNode tag props exprs -> 49 | XmlNode tag [ (k, map substBlock v) | (k,v) <- props] 50 | (map (subst key value) exprs) 51 | Let lhs rhs body -> 52 | Let lhs 53 | (subst key value rhs) 54 | (if lhs==key then body else subst key value body) 55 | App a b -> App (subst key value a) (subst key value b) 56 | Var var 57 | | var == key -> value 58 | | otherwise -> expr 59 | Con{} -> expr 60 | Lam var body 61 | | var == key -> Lam var body 62 | | otherwise -> Lam var (subst key value body) 63 | Case scrut alts -> 64 | Case (subst key value scrut) 65 | [ case pattern of 66 | PatternNode _ args 67 | | key `elem` args -> Alt pattern branch 68 | _ -> Alt pattern (subst key value branch) 69 | | Alt pattern branch <- alts ] 70 | where 71 | substBlock (VariableBlock var) 72 | | var == key = ExprBlock value 73 | | otherwise = VariableBlock var 74 | substBlock (TextBlock txt) = TextBlock txt 75 | substBlock (ExprBlock e) = ExprBlock (subst key value e) 76 | 77 | 78 | binOpInt a b fn = do 79 | a' <- evalExpr a 80 | b' <- evalExpr b 81 | case (a', b') of 82 | (LitInt aI, LitInt bI) -> pure (fn aI bI) 83 | _ -> error $ "Expected two integer arguments" 84 | 85 | unOpInt a fn = do 86 | a' <- evalExpr a 87 | case a' of 88 | LitInt aI -> pure (fn aI) 89 | _ -> error $ "Expected single integer argument" 90 | 91 | binOpFloat a b fn = do 92 | a' <- evalExpr a 93 | b' <- evalExpr b 94 | case (a', b') of 95 | (LitFloat aF, LitFloat bF) -> pure (fn aF bF) 96 | _ -> error $ "Expected two float arguments" 97 | 98 | unOpFloat a fn = do 99 | a' <- evalExpr a 100 | case a' of 101 | LitFloat aF -> pure (fn aF) 102 | _ -> error $ "Expected single float argument" 103 | 104 | evalExpr :: Expr -> Eval Expr 105 | evalExpr expr = -- trace ("Eval: " ++ show expr )$ 106 | case expr of 107 | LitChar{} -> pure expr 108 | LitString str -> LitString <$> interpolate str 109 | LitInt{} -> pure expr 110 | LitFloat{} -> pure expr 111 | XmlNode tag props exprs -> 112 | XmlNode tag <$> mapM evalProp props 113 | <*> (concatMap flattenExpr <$> mapM evalExpr exprs) 114 | Let lhs rhs body -> evalExpr (subst lhs rhs body) 115 | 116 | App (App (Var "ltI") a) b -> binOpInt a b $ \aI bI -> 117 | if aI < bI then Con "True" else Con "False" 118 | 119 | App (App (Var "plusI") a) b -> binOpInt a b $ \aI bI -> LitInt (aI+bI) 120 | App (App (Var "plus") a) b -> binOpFloat a b $ \aF bF -> LitFloat (aF+bF) 121 | App (App (Var "times") a) b -> binOpFloat a b $ \aF bF -> LitFloat (aF*bF) 122 | App (App (Var "div") a) b -> binOpFloat a b $ \aF bF -> LitFloat (aF/bF) 123 | 124 | App (Var "cos") a -> unOpFloat a $ \aF -> LitFloat (cos aF) 125 | App (Var "sin") a -> unOpFloat a $ \aF -> LitFloat (sin aF) 126 | App (Var "itof") a -> unOpInt a $ \aI -> LitFloat (fromIntegral aI) 127 | 128 | Var "pi" -> pure $ LitFloat pi 129 | 130 | App a b -> do 131 | a' <- evalExpr a 132 | case a' of 133 | Lam var body -> evalExpr $ Let var b body 134 | Con{} -> App a' <$> evalExpr b 135 | App{} -> App a' <$> evalExpr b 136 | _ -> error $ "App/Lam mismatch: " ++ show a' 137 | Var var -> do 138 | mbSubst <- asks (Map.lookup var) 139 | case mbSubst of 140 | Nothing -> error $ "Undefined var: " ++ var -- pure $ Var var 141 | Just val -> evalExpr val 142 | Con con -> pure (Con con) 143 | Lam var body -> pure $ Lam var body 144 | Case scrut alts -> do 145 | scrut' <- evalExpr scrut 146 | findAlternative scrut' alts 147 | -- _ -> error $ "Unhandled evalExpr: " ++ show expr 148 | 149 | flattenExpr :: Expr -> [Expr] 150 | flattenExpr expr = 151 | case expr of 152 | Con "Nil" -> [] 153 | App (App (Con "Cons") a) b -> a : flattenExpr b 154 | _ -> [expr] 155 | 156 | evalProp :: (String, FvgString) -> Eval (String, FvgString) 157 | evalProp (key, value) = (key,) <$> interpolate value 158 | 159 | findAlternative :: Expr -> [Alt] -> Eval Expr 160 | findAlternative _ [] = error "No valid case branch" 161 | findAlternative expr (Alt pattern branch:xs) = 162 | case (expr, pattern) of 163 | (LitChar c, PatternChar c') | c==c' -> evalExpr branch 164 | (LitInt i, PatternInt i') | i==i' -> evalExpr branch 165 | (_, PatternNode pCon pArgs) 166 | | Just (con, args) <- getCon [] expr 167 | , pCon == con 168 | -> evalExpr (substMany (zip pArgs args) branch) 169 | _ -> findAlternative expr xs 170 | where 171 | getCon acc (App a b) = getCon (b:acc) a 172 | getCon acc (Con con) = Just (con, acc) 173 | getCon _ _ = Nothing 174 | 175 | 176 | interpolate :: FvgString -> Eval FvgString 177 | interpolate inp = concat <$> mapM worker inp 178 | where 179 | worker (TextBlock txt) = pure [TextBlock txt] 180 | worker (ExprBlock expr) = do 181 | expr' <- evalExpr expr 182 | case expr' of 183 | LitString txt -> pure txt 184 | LitChar c -> pure [TextBlock (show c)] 185 | LitInt i -> pure [TextBlock (show i)] 186 | _ -> pure [TextBlock (show expr')] 187 | worker (VariableBlock var) = do 188 | mbExpr <- asks (Map.lookup var) 189 | case mbExpr of 190 | Nothing -> pure [VariableBlock var] 191 | Just expr -> worker (ExprBlock expr) 192 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser (runParse, parseModule) where 2 | 3 | import AbsSyn 4 | 5 | import Control.Monad 6 | import Data.Char 7 | import Text.Parsec 8 | import Text.Parsec.Language 9 | import qualified Text.Parsec.Token as P 10 | 11 | type Parse a = Parsec String Int a 12 | runParse :: Parse a -> String -> a 13 | runParse p inp = 14 | case runParser (whiteSpace >> p) 1 "inp" inp of 15 | Left err -> error (show err) 16 | Right v -> v 17 | 18 | checkIndent :: Parse () 19 | checkIndent = do 20 | pos <- getPosition 21 | req <- getState 22 | when (sourceColumn pos < req) $ 23 | unexpected "indentation" 24 | 25 | block :: Parse a -> Parse a 26 | block p = do 27 | whiteSpace 28 | pos <- getPosition 29 | i <- getState 30 | setState (sourceColumn pos) 31 | v <- p 32 | setState i 33 | return v 34 | 35 | indent :: Parse a -> Parse a 36 | indent p = do 37 | i <- getState 38 | setState (i+1) 39 | v <- p 40 | setState i 41 | return v 42 | 43 | lexer = P.makeTokenParser haskellDef 44 | identifier = P.identifier lexer 45 | reserved = P.reserved lexer 46 | reservedOp = P.reservedOp lexer 47 | parens = P.parens lexer 48 | symbol = P.symbol lexer 49 | stringLiteral = P.stringLiteral lexer 50 | charLiteral = P.charLiteral lexer 51 | integer = P.integer lexer 52 | float = P.float lexer 53 | whiteSpace = P.whiteSpace lexer 54 | 55 | parseUpperName :: Parse String 56 | parseUpperName = try $ do 57 | name <- identifier 58 | unless (isUpper $ head name) $ fail "Wanted upper case letter" 59 | return name 60 | 61 | parseLowerName :: Parse String 62 | parseLowerName = try $ do 63 | name <- identifier 64 | unless (isLower $ head name) $ fail "Wanted upper case letter" 65 | return name 66 | 67 | parseModule :: Parse Module 68 | parseModule = do 69 | ds <- many parseDataDecl 70 | fs <- many parseFunDecl 71 | return $ Module ds fs 72 | 73 | parseDataDecl :: Parse DataDecl 74 | parseDataDecl = do 75 | reserved "data" 76 | name <- parseUpperName 77 | tyArgs <- many parseLowerName 78 | reservedOp "=" 79 | cons <- indent (parseDataConstructor `sepBy1` reservedOp "|") 80 | return $ DataDecl name tyArgs cons 81 | 82 | parseDataConstructor :: Parse DataConstructor 83 | parseDataConstructor = checkIndent >> do 84 | con <- parseUpperName 85 | fields <- many parseAType 86 | return $ DataConstructor con fields 87 | "data constructor" 88 | 89 | parseTyVar :: Parse TyVar 90 | parseTyVar = parseLowerName 91 | 92 | 93 | parseType :: Parse Type 94 | parseType = 95 | fold <$> parseBType 96 | <*> many (symbol "->" *> parseBType) 97 | where 98 | fold t [] = t 99 | fold t (x:xs) = TyFun t (fold x xs) 100 | 101 | 102 | parseBType :: Parse Type 103 | parseBType = foldl TyApp <$> parseAType <*> many parseAType 104 | 105 | parseAType :: Parse Type 106 | parseAType = checkIndent >> msum 107 | [ TyVar <$> parseLowerName 108 | , TyCon <$> parseUpperName 109 | , parens parseType 110 | ] 111 | 112 | 113 | parseFunDecl :: Parse FunDecl 114 | parseFunDecl = do 115 | fnName <- parseLowerName 116 | reservedOp ":" 117 | fnType <- indent parseType 118 | symbol fnName 119 | args <- many parseLowerName 120 | reservedOp "=" 121 | body <- indent parseExpr 122 | return $ FunDecl fnName fnType args body 123 | 124 | parseExpr :: Parse Expr 125 | parseExpr = checkIndent >> msum 126 | [ parseApp 127 | , parseLet 128 | , parseLambda 129 | , parseCase ] 130 | "expression" 131 | 132 | parseApp :: Parse Expr 133 | parseApp = do 134 | e <- parseSingleExpr 135 | es <- many parseSingleExpr 136 | return $ foldl App e es 137 | 138 | parseLambda :: Parse Expr 139 | parseLambda = do 140 | reservedOp "\\" 141 | var <- parseLowerName 142 | reservedOp "->" 143 | body <- parseExpr 144 | return $ Lam var body 145 | "lambda" 146 | 147 | parseSingleExpr :: Parse Expr 148 | parseSingleExpr = checkIndent >> msum 149 | [ parseLitChar 150 | , try parseLitFloat 151 | , parseLitInt 152 | , parseLitString 153 | , parseXmlNode 154 | , parens parseExpr 155 | , parseVariable 156 | , parseConstructor ] 157 | 158 | parseVariable :: Parse Expr 159 | parseVariable = Var <$> parseLowerName 160 | 161 | parseConstructor :: Parse Expr 162 | parseConstructor = Con <$> parseUpperName 163 | 164 | parseLitChar :: Parse Expr 165 | parseLitChar = LitChar <$> charLiteral 166 | 167 | parseLitString :: Parse Expr 168 | parseLitString = (LitString . parseFvgString) <$> stringLiteral 169 | 170 | parseLitInt :: Parse Expr 171 | parseLitInt = LitInt <$> integer 172 | 173 | parseLitFloat :: Parse Expr 174 | parseLitFloat = LitFloat <$> float 175 | 176 | parseXmlNode :: Parse Expr 177 | parseXmlNode = block $ do 178 | reservedOp "<" 179 | node <- identifier 180 | props <- many $ do 181 | key <- identifier <|> stringLiteral 182 | reservedOp "=" 183 | value <- stringLiteral 184 | return (key, parseFvgString value) 185 | reservedOp ">" 186 | children <- indent (parseExpr `sepBy` reservedOp ";") 187 | checkIndent 188 | reservedOp "" 191 | return $ XmlNode node props children 192 | 193 | parseLet :: Parse Expr 194 | parseLet = do 195 | reserved "let" 196 | lhs <- parseLowerName 197 | reservedOp "=" 198 | rhs <- parseExpr 199 | reserved "in" 200 | body <- parseExpr 201 | return $ Let lhs rhs body 202 | "let" 203 | 204 | parseCase :: Parse Expr 205 | parseCase = block $ do 206 | reserved "case" 207 | scrut <- parseExpr 208 | reserved "of" 209 | alts <- indent $ many1 (checkIndent >> parseAlt) 210 | return $ Case scrut alts 211 | 212 | -- pattern -> expr 213 | parseAlt :: Parse Alt 214 | parseAlt = block $ do 215 | pattern <- parsePattern 216 | symbol "->" 217 | expr <- indent $ parseExpr 218 | return $ Alt pattern expr 219 | 220 | -- 10 221 | -- 'c' 222 | -- Node a b c 223 | parsePattern :: Parse Pattern 224 | parsePattern = checkIndent >> msum 225 | [ PatternChar <$> charLiteral 226 | , PatternInt <$> integer 227 | , PatternNode <$> parseUpperName <*> many parseLowerName ] 228 | 229 | parseFvgString :: String -> FvgString 230 | parseFvgString = merge . findStartMark 231 | where 232 | merge (TextBlock a:TextBlock b:xs)= merge (TextBlock (a++b):xs) 233 | merge (x:xs) = x:merge xs 234 | merge [] = [] 235 | findStartMark ('{':'{':started) = 236 | let (var, rest) = findEndMark "" started 237 | in VariableBlock var : parseFvgString rest 238 | findStartMark (x:xs) = TextBlock [x] : findStartMark xs 239 | findStartMark [] = [] 240 | findEndMark acc ('}':'}':xs) = (reverse acc,xs) 241 | findEndMark acc (x:xs) = findEndMark (x:acc) xs 242 | findEndMark acc [] = (reverse acc, []) 243 | -------------------------------------------------------------------------------- /src/TypeChecker.hs: -------------------------------------------------------------------------------- 1 | module TypeChecker (typecheck) where 2 | 3 | import AbsSyn 4 | 5 | import Control.Monad.State.Strict 6 | import Data.List 7 | import Data.Map (Map) 8 | import qualified Data.Map as Map 9 | 10 | floatTy :: Type 11 | floatTy = TyCon "Float" 12 | 13 | intTy :: Type 14 | intTy = TyCon "Int" 15 | 16 | boolTy :: Type 17 | boolTy = TyCon "Bool" 18 | 19 | infixr 1 --> 20 | (-->) :: Type -> Type -> Type 21 | t1 --> t2 = TyFun t1 t2 22 | 23 | knownTypes :: [(String, Int)] 24 | knownTypes = [("Int",0), ("Char",0), ("String",0), ("Float", 0), ("Bool", 0)] 25 | 26 | knownFunctions :: [(String, Qual)] 27 | knownFunctions = 28 | [ ("cos", [] :=> floatTy --> floatTy) 29 | , ("sin", [] :=> floatTy --> floatTy) 30 | , ("pi", [] :=> floatTy) 31 | , ("itof", [] :=> intTy --> floatTy) 32 | , ("True", [] :=> boolTy) 33 | , ("False", [] :=> boolTy) 34 | , ("eqI", [] :=> intTy --> intTy --> boolTy) 35 | , ("ltI", [] :=> intTy --> intTy --> boolTy) 36 | , ("plusI", [] :=> intTy --> intTy --> intTy) 37 | , ("plus", [] :=> floatTy --> floatTy --> floatTy) 38 | , ("times", [] :=> floatTy --> floatTy --> floatTy) 39 | , ("div", [] :=> floatTy --> floatTy --> floatTy) 40 | ] 41 | 42 | -- Check kinds 43 | -- check top binds 44 | -- infer lets 45 | typecheck :: Module -> Module 46 | typecheck m = evalState action env `seq` m 47 | where 48 | env = Env 49 | { envUnique = 0 50 | , envKinds = Map.fromList knownTypes 51 | , envScope = Map.fromList knownFunctions 52 | , envSubst = Map.empty 53 | } 54 | action = do 55 | mapM_ checkDataDecl (modDataDecls m) 56 | mapM_ checkFunDecl (modFunDecls m) 57 | 58 | infixr 0 :=> 59 | data Qual = [TyVar] :=> Type 60 | deriving (Eq, Show) 61 | 62 | data Env = Env 63 | { envUnique :: Int 64 | , envKinds :: Map String Int -- Arity of types 65 | , envScope :: Map String Qual 66 | , envSubst :: Map TyVar Type 67 | } 68 | type M a = State Env a 69 | 70 | simpleQual :: Type -> Qual 71 | simpleQual ty = tv ty :=> ty 72 | 73 | insertType :: String -> Qual -> M () 74 | insertType name ty = 75 | modify $ \st -> st 76 | { envScope = Map.insert name ty (envScope st) } 77 | 78 | withTypes :: [(String, Qual)] -> M a -> M a 79 | withTypes [] = id 80 | withTypes ((k,v):xs) = withType k v . withTypes xs 81 | 82 | withType :: String -> Qual -> M a -> M a 83 | withType name ty action = do 84 | mbPrevTy <- gets (Map.lookup name . envScope) 85 | insertType name ty 86 | ret <- action 87 | case mbPrevTy of 88 | Nothing -> modify $ \st -> st 89 | { envScope = Map.delete name (envScope st) } 90 | Just prev -> modify $ \st -> st 91 | { envScope = Map.insert name prev (envScope st) } 92 | return ret 93 | 94 | 95 | newSubst :: TyVar -> Type -> M () 96 | newSubst tyvar ty = 97 | modify $ \st -> st 98 | { envSubst = Map.insert tyvar ty (envSubst st) } 99 | 100 | tv :: Type -> [TyVar] 101 | tv (TyVar var) = [var] 102 | tv TyCon{} = [] 103 | tv (TyFun t1 t2) = nub $ tv t1 ++ tv t2 104 | tv (TyApp t1 t2) = nub $ tv t1 ++ tv t2 105 | 106 | newTyVar :: TyVar -> M TyVar 107 | newTyVar var = do 108 | st <- get 109 | let u = envUnique st 110 | put st{envUnique = u+1} 111 | return $ "new_" ++ var ++ "_" ++ show u 112 | 113 | newAnyType :: M Type 114 | newAnyType = TyVar <$> newTyVar "any" 115 | 116 | 117 | instantiate :: Qual -> M Type 118 | instantiate (tyvars :=> ty) = do 119 | vars' <- mapM newTyVar tyvars 120 | return $ replace (zip tyvars vars') ty 121 | 122 | replace lst ty = 123 | case ty of 124 | TyVar var -> 125 | case lookup var lst of 126 | Nothing -> TyVar var 127 | Just newVar -> TyVar newVar 128 | TyCon{} -> ty 129 | TyFun t1 t2 -> TyFun (replace lst t1) (replace lst t2) 130 | TyApp t1 t2 -> TyApp (replace lst t1) (replace lst t2) 131 | 132 | normalize :: Qual -> Qual 133 | normalize (tyvars :=> ty) = newVars :=> replace subst ty 134 | where 135 | newVars = map show [1 .. length tyvars] 136 | subst = zip tyvars newVars 137 | 138 | qualFreeTyVars :: Qual -> [TyVar] 139 | qualFreeTyVars (bound :=> ty) = tv ty \\ bound 140 | 141 | generalize :: Type -> M Qual 142 | generalize ty = do 143 | tys <- gets (Map.elems . envScope) 144 | let free = nub $ concatMap qualFreeTyVars tys 145 | gen = tv ty \\ free 146 | return $ gen :=> ty 147 | 148 | -- Lookup and instantiate type. 149 | freshType :: String -> M Type 150 | freshType ident = do 151 | qual <- gets $ \st -> Map.findWithDefault err ident (envScope st) 152 | instantiate qual 153 | where 154 | err = error $ "Ident not found: " ++ ident 155 | 156 | -- Apply substitutions 157 | apply :: Type -> M Type 158 | apply ty = do 159 | s <- gets envSubst 160 | return $ worker s ty 161 | where 162 | worker s (TyVar var) = 163 | case Map.lookup var s of 164 | Nothing -> TyVar var 165 | Just newTy -> worker s newTy 166 | worker s (TyCon con) = TyCon con 167 | worker s (TyFun t1 t2) = TyFun (worker s t1) (worker s t2) 168 | worker s (TyApp t1 t2) = TyApp (worker s t1) (worker s t2) 169 | 170 | -- = TyVar TyVar 171 | -- | TyCon TypeName 172 | -- | TyFun Type Type 173 | -- | TyApp Type Type 174 | mgu :: Type -> Type -> M () 175 | mgu (TyApp l r) (TyApp l' r') = do 176 | mgu l l' 177 | join $ liftM2 mgu (apply r) (apply r') 178 | mgu (TyFun l r) (TyFun l' r') = do 179 | mgu l l' 180 | join $ liftM2 mgu (apply r) (apply r') 181 | mgu (TyVar u) t = varBind u t 182 | mgu t (TyVar u) = varBind u t 183 | mgu (TyCon tc1) (TyCon tc2) | tc1 == tc2 = return () 184 | mgu t1 t2 = error $ "Unification failure: " ++ show (t1,t2) 185 | 186 | varBind :: TyVar -> Type -> M () 187 | varBind u t 188 | | t == TyVar u = return () 189 | | u `elem` tv t = error $ "occurs check failed: " ++ show (u, t) 190 | | otherwise = newSubst u t 191 | 192 | unify :: Type -> Type -> M () 193 | unify t1 t2 = join $ liftM2 mgu (apply t1) (apply t2) 194 | 195 | checkDataDecl :: DataDecl -> M () 196 | checkDataDecl (DataDecl name args cons) = do 197 | modify $ \st -> st{envKinds = Map.insert name (length args) (envKinds st) } 198 | let retTy = foldl TyApp (TyCon name) (map TyVar args) 199 | mapM_ (checkConstructor retTy) cons 200 | 201 | checkConstructor :: Type -> DataConstructor -> M () 202 | checkConstructor retType (DataConstructor name fields) = do 203 | insertType name (simpleQual $ foldr TyFun retType fields) 204 | mapM_ checkType fields 205 | 206 | -- Check validity of type and return it's arity. 207 | checkType :: Type -> M Int 208 | checkType ty = 209 | case ty of 210 | TyVar{} -> return 0 211 | TyCon ty -> gets $ \st -> envKinds st Map.! ty 212 | TyFun t1 t2 -> do 213 | a1 <- checkType t1 214 | when (a1/=0) $ error $ "Higher kinded types not allowed: " ++ show t1 215 | a2 <- checkType t2 216 | when (a2/=0) $ error $ "Higher kinded types not allowed: " ++ show t2 217 | return 0 218 | TyApp t1 t2 -> do 219 | a1 <- checkType t1 220 | when (a1==0) $ error $ "Arity 0 in TyApp: " ++ show (t1, t2) 221 | a2 <- checkType t2 222 | when (a2/=0) $ error $ "Higher kinded types not allowed: " ++ show (t1, t2) 223 | return (a1-1) 224 | 225 | checkFunDecl :: FunDecl -> M () 226 | checkFunDecl (FunDecl name ty args body) = do 227 | let qual = simpleQual ty 228 | checkType ty 229 | insertType name qual 230 | let expr = foldr Lam body args 231 | exprTy <- inferType expr 232 | fnInstTy <- instantiate qual 233 | unify fnInstTy exprTy 234 | 235 | exprTy' <- apply exprTy 236 | genTy <- generalize =<< apply exprTy 237 | when (normalize (simpleQual ty) /= normalize genTy) $ 238 | error $ "Type error: " ++ show (normalize (simpleQual ty)) ++ "\n" ++ show (normalize genTy) ++ "\n" ++ show exprTy' ++ "\n" ++ show exprTy 239 | 240 | inferType :: Expr -> M Type 241 | inferType expr = 242 | case expr of 243 | LitChar{} -> pure $ TyCon "Char" 244 | LitInt{} -> pure intTy 245 | LitFloat{} -> pure floatTy 246 | LitString{} -> pure $ TyCon "String" 247 | XmlNode _tag _props exprs -> do 248 | let t = TyCon "Svg" 249 | mapM_ inferType exprs 250 | return t 251 | Let lhs rhs body -> do 252 | rhsTy <- inferType rhs 253 | genTy <- generalize rhsTy 254 | withType lhs genTy $ 255 | inferType body 256 | App a b -> do 257 | aTy <- inferType a 258 | bTy <- inferType b 259 | t <- newAnyType 260 | unify aTy (bTy `TyFun` t) 261 | return t 262 | Var var -> freshType var 263 | Con con -> freshType con 264 | Lam var body -> do 265 | varTy <- newAnyType 266 | withType var ([] :=> varTy) $ do 267 | bodyTy <- inferType body 268 | return (varTy `TyFun` bodyTy) 269 | Case scrut alts -> do 270 | retTy <- newAnyType 271 | scrutTy <- inferType scrut 272 | forM_ alts $ \(Alt pattern branch) -> do 273 | case pattern of 274 | PatternChar{} -> do 275 | unify scrutTy (TyCon "Char") 276 | unify retTy =<< inferType branch 277 | PatternInt{} -> do 278 | unify scrutTy (TyCon "Char") 279 | unify retTy =<< inferType branch 280 | PatternNode con args -> do 281 | argTypes <- replicateM (length args) newAnyType 282 | conRet <- newAnyType 283 | conTy <- freshType con 284 | unify (foldr TyFun conRet argTypes) conTy 285 | unify conRet scrutTy 286 | withTypes (zip args (map ([] :=>) argTypes)) $ 287 | unify retTy =<< inferType branch 288 | return retTy 289 | -------------------------------------------------------------------------------- /tests/Case1.fvg: -------------------------------------------------------------------------------- 1 | data Bool = True | False 2 | 3 | main : Int 4 | main = 5 | case True of 6 | True -> 1 7 | False -> 0 8 | -------------------------------------------------------------------------------- /tests/Case1.out: -------------------------------------------------------------------------------- 1 | 1 -------------------------------------------------------------------------------- /tests/Circle.fvg: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) 2 | data Tuple a b = Tuple a b 3 | 4 | enumerate : Int -> Int -> (Int -> a) -> List a 5 | enumerate n max fn = 6 | case ltI n max of 7 | False -> Nil 8 | True -> Cons (fn n) (enumerate (plusI n 1) max fn) 9 | 10 | mkCoords : Int -> Float -> List (Tuple Float Float) 11 | mkCoords n radius = 12 | let width = plus (times radius 2.0) 50.0 in 13 | enumerate 0 n (\i -> 14 | let angle = times (div (itof i) (div (itof n) 2.0)) pi in 15 | let x = plus (times radius (cos angle)) (div width 2.0) in 16 | let y = plus (times radius (sin angle)) (div width 2.0) in 17 | Tuple x y 18 | ) 19 | 20 | for : List a -> (a -> b) -> List b 21 | for lst fn = 22 | case lst of 23 | Nil -> Nil 24 | Cons x xs -> Cons (fn x) (for xs fn) 25 | 26 | main : Svg 27 | main = 28 | let radius = 200.0 in 29 | let size = plus (times radius 2.0) 50.0 in 30 | 31 | for (mkCoords 10 radius) (\tuple -> 32 | case tuple of 33 | Tuple x y -> 34 | 35 | ) 36 | 37 | -------------------------------------------------------------------------------- /tests/Circle.out: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/Circle.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lemmih/fvg/2f758cc19b9dc087a31b6a42c62b26b7c04e02bf/tests/Circle.png -------------------------------------------------------------------------------- /tests/Enumerate.fvg: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) 2 | 3 | enumerate : Int -> Int -> (Int -> a) -> List a 4 | enumerate n max fn = 5 | case ltI n max of 6 | False -> Nil 7 | True -> Cons (fn n) (enumerate (plusI n 1) max fn) 8 | 9 | main : List Int 10 | main = enumerate 0 10 (\x -> x) -- mkCoords 10 10.0 11 | -------------------------------------------------------------------------------- /tests/Enumerate.out: -------------------------------------------------------------------------------- 1 | Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 (Cons 5 (Cons 6 (Cons 7 (Cons 8 (Cons 9 Nil))))))))) -------------------------------------------------------------------------------- /tests/HOF.fvg: -------------------------------------------------------------------------------- 1 | apply : (a -> b) -> (a -> b) 2 | apply f a = f a 3 | 4 | dot : (b -> c) -> (a -> b) -> a -> c 5 | dot f g x = f (g x) 6 | 7 | main : Svg 8 | main = 9 | 10 | 11 | apply (plusI 1) 2 12 | ; 13 | 14 | dot (plusI 1) (plusI 10) 5 15 | 16 | 17 | -------------------------------------------------------------------------------- /tests/HOF.out: -------------------------------------------------------------------------------- 1 | 3 16 -------------------------------------------------------------------------------- /tests/HOF.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lemmih/fvg/2f758cc19b9dc087a31b6a42c62b26b7c04e02bf/tests/HOF.png -------------------------------------------------------------------------------- /tests/HelloWorld.fvg: -------------------------------------------------------------------------------- 1 | main : Svg 2 | main = 3 | 4 | "Hello World" 5 | 6 | -------------------------------------------------------------------------------- /tests/HelloWorld.out: -------------------------------------------------------------------------------- 1 | Hello World -------------------------------------------------------------------------------- /tests/HelloWorld.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lemmih/fvg/2f758cc19b9dc087a31b6a42c62b26b7c04e02bf/tests/HelloWorld.png -------------------------------------------------------------------------------- /tests/Let1.fvg: -------------------------------------------------------------------------------- 1 | main : Int 2 | main = let id = \x -> x in id 10 3 | -------------------------------------------------------------------------------- /tests/Let1.out: -------------------------------------------------------------------------------- 1 | 10 -------------------------------------------------------------------------------- /tests/Let2.fvg: -------------------------------------------------------------------------------- 1 | main : Int 2 | main = let id = \x -> x in id 'c' 3 | -------------------------------------------------------------------------------- /tests/Lists.fvg: -------------------------------------------------------------------------------- 1 | data List a = Nil | Cons a (List a) 2 | 3 | map : (a -> b) -> List a -> List b 4 | map fn lst = 5 | case lst of 6 | Nil -> Nil 7 | Cons x xs -> Cons (fn x) (map fn xs) 8 | 9 | main : Svg 10 | main = 11 | let x = map (plusI 1) (Cons 10 (Cons 20 Nil)) in 12 | 13 | "List output:" ; 14 | "{{x}}" 15 | 16 | -------------------------------------------------------------------------------- /tests/Lists.out: -------------------------------------------------------------------------------- 1 | List output: Cons 11 (Cons 21 Nil) -------------------------------------------------------------------------------- /tests/Lists.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lemmih/fvg/2f758cc19b9dc087a31b6a42c62b26b7c04e02bf/tests/Lists.png -------------------------------------------------------------------------------- /tests/Poly1.fvg: -------------------------------------------------------------------------------- 1 | id : a -> a 2 | id x = x 3 | 4 | main : Int 5 | main = id 10 6 | -------------------------------------------------------------------------------- /tests/Poly1.out: -------------------------------------------------------------------------------- 1 | 10 -------------------------------------------------------------------------------- /tests/Poly2.fvg: -------------------------------------------------------------------------------- 1 | id : a -> a 2 | id x = x 3 | 4 | main : a -> a 5 | main = id 6 | -------------------------------------------------------------------------------- /tests/Poly2.out: -------------------------------------------------------------------------------- 1 | \x -> x -------------------------------------------------------------------------------- /tests/Poly3.fvg: -------------------------------------------------------------------------------- 1 | id : a -> a 2 | id x = x 3 | 4 | main : b -> b 5 | main = id 6 | -------------------------------------------------------------------------------- /tests/Poly3.out: -------------------------------------------------------------------------------- 1 | \x -> x -------------------------------------------------------------------------------- /tests/Poly4.fvg: -------------------------------------------------------------------------------- 1 | id : Int -> Int 2 | id x = x 3 | 4 | main : a -> a 5 | main = id 6 | -------------------------------------------------------------------------------- /tests/Poly5.fvg: -------------------------------------------------------------------------------- 1 | id : a -> a 2 | id x = x 3 | 4 | main : Int 5 | main = id 'c' 6 | -------------------------------------------------------------------------------- /tests/runtests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import AbsSyn 4 | import Parser 5 | import Interpreter 6 | 7 | import System.Directory 8 | import System.FilePath 9 | import System.Environment 10 | import Control.Exception 11 | import Control.Monad 12 | import Text.Printf 13 | import Data.List 14 | 15 | main :: IO () 16 | main = do 17 | args <- getArgs 18 | case args of 19 | [file] -> do 20 | inp <- readFile file 21 | let outFile = replaceExtension file "out" 22 | expr <- evaluate (runScript inp) 23 | writeFile outFile (show expr) 24 | _ -> do 25 | files <- getDirectoryContents "." 26 | forM_ (sort files) $ \file -> 27 | when (takeExtension file == ".fvg") $ do 28 | inp <- readFile file 29 | let outFile = replaceExtension file "out" 30 | hasOut <- doesFileExist outFile 31 | if hasOut 32 | then do 33 | out <- readFile outFile 34 | ret <- try $ evaluate (runScript inp) 35 | case ret :: Either SomeException Expr of 36 | Left{} -> unexpectedFailure file 37 | Right expr 38 | | show expr == out -> ok file 39 | | otherwise -> mismatch file 40 | else do 41 | ret <- try $ evaluate (runScript inp) 42 | case ret :: Either SomeException Expr of 43 | Left{} -> ok file 44 | Right{} -> expectedFailure file 45 | 46 | ok file = printf "%15s: [OK]\n" (takeBaseName file) 47 | expectedFailure file = printf "%15s: [BAD, EXPECTED FAILURE]\n" (takeBaseName file) 48 | unexpectedFailure file = printf "%15s: [BAD, UNEXPECTED FAILURE]\n" (takeBaseName file) 49 | mismatch file = printf "%15s: [BAD, OUTPUT MISMATCH]\n" (takeBaseName file) 50 | --------------------------------------------------------------------------------