diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,6 +7,10 @@ stack install language-elm ``` +## Documentation +[Documentation](https://hackage.haskell.org/package/language-elm) + + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple +import Distribution.Simple main = defaultMain diff --git a/language-elm.cabal b/language-elm.cabal --- a/language-elm.cabal +++ b/language-elm.cabal @@ -1,5 +1,5 @@ name: language-elm -version: 0.0.10.1 +version: 0.1.0.0 synopsis: Generate elm code description: Generate elm code from an ast homepage: https://github.com/eliaslfox/language-elm#readme @@ -15,20 +15,25 @@ library hs-source-dirs: src - exposed-modules: Elm.Decleration, Elm.Expression, Elm.Import, Elm.Program, Elm.Type - build-depends: base >= 4.7 && < 5, - pretty, - MissingH + exposed-modules: Elm.Decleration, Elm.Expression, Elm.Import, Elm.Program, Elm.Type, Elm.Classes, Elm.GenError + build-depends: base >= 4.9.1 && < 4.10, + pretty >= 1.1.3 && < 1.2, + MissingH >= 1.4.0 && < 1.5, + mtl >= 2.2.1 && < 2.3, + protolude >= 0.2 && < 0.3 default-language: Haskell2010 test-suite language-elm-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Renderer build-depends: base , language-elm - , HUnit - , pretty + , pretty >= 1.1.3 && < 1.2 + , hspec >= 2.4.4 && < 2.5 + , mtl >= 2.2.1 && < 2.3 + , protolude >= 0.2 && < 0.3 ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Elm/Classes.hs b/src/Elm/Classes.hs new file mode 100644 --- /dev/null +++ b/src/Elm/Classes.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_HADDOCK -prune #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} + +-- | A series of helper classes to make writing an ast easier +module Elm.Classes where + +import Protolude () + +import Control.Monad.Writer +import Elm.GenError +import Text.PrettyPrint + +class Generate a where + generate :: a -> Writer GenError Doc diff --git a/src/Elm/Decleration.hs b/src/Elm/Decleration.hs --- a/src/Elm/Decleration.hs +++ b/src/Elm/Decleration.hs @@ -1,11 +1,15 @@ {-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Top level declerations module Elm.Decleration where -import Elm.Type -import Elm.Expression -import Text.PrettyPrint +import Elm.Classes +import Elm.Expression +import Elm.Type +import Text.PrettyPrint -- | Used to declare functions, variables, and types data Dec @@ -16,20 +20,25 @@ -- | Declare a type alias | DecTypeAlias String [String] TypeDec -toDocD :: Dec -> Doc -toDocD dec = - case dec of - Dec str typeDec args body -> - text str <+> text ":" <+> toDocT typeDec $+$ - hang (text str <+> (hsep . map toDoc $ args) <+> text "=") 4 (toDoc body) - - DecTypeAlias str typeParams t-> - text "type alias" <+> text str <+> (hsep . map text $ typeParams) <+> text "=" <+> toDocT t +instance Generate Dec where + generate dec = + case dec of + Dec name type_ params value -> do + typeDoc <- generate type_ + paramDocs <- mapM generate params + valueDoc <- generate value + return $ text name <+> ":" <+> typeDoc $+$ text name <+> hsep paramDocs <+> "=" $+$ nest 4 valueDoc - DecType str typeParams types -> - text "type" <+> text str <+> (hsep . map text $ typeParams) <+> text "=" <+> - (hsep . punctuate (text " |") . map toDec $ types) + DecType name params instances -> do + let (keys, values) = unzip instances + let keyDocs = map text keys + valueDocs <- mapM (mapM generate) values + let instanceDocs = map (\(key, values') -> key <+> hsep values') $ zip keyDocs valueDocs + let paramDocs = map text params + return $ "type" <+> text name <+> hsep paramDocs $+$ + (nest 4 $ "=" <+> head instanceDocs $+$ (vcat . map ((<+>)"|") . tail $ instanceDocs)) - where - toDec (str, t) = - text str <+> (hsep . map vopParam $ t) + DecTypeAlias name params type_ -> do + typeDoc <- generate type_ + let paramDocs = map text params + return $ "type alias" <+> text name <+> hsep paramDocs <+> "=" $+$ nest 4 typeDoc diff --git a/src/Elm/Expression.hs b/src/Elm/Expression.hs --- a/src/Elm/Expression.hs +++ b/src/Elm/Expression.hs @@ -1,126 +1,211 @@ {-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Werror -Wall #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Used to declare expressions -module Elm.Expression where +module Elm.Expression + ( Expr(..) + ) where -import Text.PrettyPrint hiding (Str) -import Data.Maybe +import Protolude +import Control.Monad (mapM, when) +import Control.Monad.Writer (tell) +import Data.String (IsString (..), String) +import Elm.Classes (Generate (..)) +import Elm.GenError (GenError (..)) +import Text.PrettyPrint hiding (Str) + -- | The expression type -data Expr - -- | Function application - = App String [Expr] - | Case Expr [(Expr, Expr)] - | Let Expr [(Expr, Expr)] - | List [Expr] - | Tuple2 Expr Expr - | Tuple3 Expr Expr Expr - -- | Inline operators - | Op String Expr Expr - -- | Expressions wrapped in parens - | Parens Expr - -- | String literals +data Expr {- + Constants + -} + -- | A boolean literal + = Bool Bool + -- | A string literal | Str String - -- | Integer literals + -- | An integer literal | Int Int - -- | The underscore placeholder + -- | A float literal + | Float Float + -- | An underscore variable placeholder | Under - -- | Boolean false literal - | BoolTrue - -- | Boolean true literal - | BoolFalse - -- | Record creation and update syntax - | Record (Maybe Expr) [(String, Expr)] - --- | Shortcut for variables -var :: String -> Expr -var str = App str [] - --- Takes an expression --- if its a single variable or tuple then id --- else wrap it in parens -vop :: Expr -> Doc -vop expr = - case expr of - App str [] -> - text str - - Tuple2 exp1 exp2 -> - toDoc $ Tuple2 exp1 exp2 - - Tuple3 expr1 expr2 expr3 -> - toDoc $ Tuple3 expr1 expr2 expr3 - - Str str -> - doubleQuotes $ text str - - Record a b -> - toDoc $ Record a b - - other -> - parens $ toDoc other - -toDoc :: Expr -> Doc -toDoc expr = - case expr of - App str exprs -> - text str <+> (hsep . map vop $ exprs) - - Tuple2 expr1 expr2 -> - parens $ toDoc expr1 <> comma <+> toDoc expr2 - - Tuple3 expr1 expr2 expr3 -> - parens $ toDoc expr1 <> comma <+> toDoc expr2 <> comma <+> toDoc expr3 - - Str str -> - doubleQuotes . text $ str - - Op op expr1 expr2 -> - vop expr1 <+> text op <+> vop expr2 - - Case expr exprs -> - hang (text "case" <+> vop expr <+> text "of") 4 (vcat . map caseToDoc $ exprs) - - where - caseToDoc (expr1, expr2) = - toDoc expr1 <+> text "->" $$ (nest 4 $ toDoc expr2) - - - List exprs -> - char '[' <> (hsep . punctuate (text ",") . map toDoc $ exprs) <> char ']' - - Let expr exprs -> - text "let" $+$ (nest 4 . vcat . map letToDoc $ exprs) $+$ text "in" $+$ (nest 4 $ toDoc expr) - - where - letToDoc (expr1, expr2) = - toDoc expr1 <+> char '=' <+> toDoc expr2 - - Int i -> - int i - - Under -> - char '_' - - BoolTrue -> - text "True" - - BoolFalse -> - text "False" - - Record Nothing [] -> - text "{}" + {- + Inline + -} + -- | A variable + | Var String + -- | Function application, the tail is applied to the head + | App [Expr] + -- | A list of expressions + | List [Expr] + -- | Apply an inline operator to two expressions + | Op String + Expr + Expr + -- | A tuple of expressions + | Tuple [Expr] + -- | A record, the first paramater is an optional record to update from + | Record (Maybe Expr) + [(String, Expr)] + {- + Multi Line + -} + -- | A let expression + | Let Expr + [(Expr, Expr)] + -- | A case expression + | Case Expr + [(Expr, Expr)] + {- + Util + -} + -- | Wrap an expression in parens, should be mostly automatic + | Parens Expr - Record (Just main) [] -> - toDoc main +-- | Allows creating variables with overloaded strings +instance IsString Expr where + fromString = Var - Record main parts -> - let - front = fmap (\x -> toDoc x <+> char '|') main - in - char '{' <+> (Data.Maybe.fromMaybe empty front) - <+> nest 4 (hsep . punctuate (char ',') . map docPart $ parts) - <+> char '}' - where - docPart (name, value) = - text name <+> char '=' <+> toDoc value +instance Generate Expr where + generate expr = + case expr of + Var str -> do + when (str == "") $ + tell $ Error "An empty string is not a valid variable name" + return $ text str + App [] + -- I don't think this has a valid meaning + -> do + tell $ Error "Invalid syntax, trying to apply nothing" + return $ text "" + App [expr'] -> generate expr' + App exprs + -- If only I could understand my own code :( + -> do + docs <- mapM vop exprs + return . hsep $ docs + Tuple [] -> + return "()" + Tuple items -> do + when (length items > 9) $ + tell $ Error "Length of tuple is too long" + when (length items > 7) $ + tell $ + WarningList + [ "Tuples of length longer than seven are not comparable" + ] + docs <- mapM generate items + return $ lparen <+> (hsep . punctuate "," $ docs) <+> rparen + Str str -> return . doubleQuotes . text $ str + Op op expr1 expr2 -> do + doc1 <- vop expr1 + doc2 <- vop expr2 + return $ doc1 <+> text op <+> doc2 + Case _ [] -> do + tell $ Error "Unable to create case expression with 0 cases" + return "" + Case value options -> do + docValue <- generate value + optionsList <- genCaseList options + return $ "case" <+> docValue <+> "of" $+$ nest 4 optionsList + List items -> do + docs <- mapM generate items + return . brackets . hsep . punctuate "," $ docs + Let _ [] -> do + tell $ Error "Unable to create let expression with 0 bindings" + return "" + Let value bindings -> do + bindingsList <- genLetList bindings + valueDoc <- generate value + return $ + "let" $+$ nest 4 bindingsList $+$ "in" $+$ nest 4 valueDoc + Int val -> do + when (val > 9007199254740991) $ + -- I would love for someone, somewhere, to get this warning + tell $ + WarningList + [ "The number " ++ + show val ++ + " is larger than the largest safe number in js" + ] + return . int $ val + Float val -> do + when (val > 9007199254740991) $ + tell $ + WarningList + [ "The number " ++ + show val ++ + " is larger that the largest safe number in js" + ] + return . float $ val + Under -> return . char $ '_' + Bool bool' -> + if bool' + then return . text $ "True" + else return . text $ "False" + Record Nothing [] -> return "{}" + Record (Just (Var str)) [] + -- tbh, what would you even be trying to do? + -> do + tell $ + WarningList + [ "Trying to update record " ++ + str ++ " with no changed fields" + ] + return . text $ str + Record (Just (Var str)) updates -> do + list' <- genRecordList updates + return $ lbrace <+> text str <+> "|" <+> list' <+> rbrace + Record (Just _) _ + -- This seems to be how it is + -> do + tell $ + Error + "You are unable to update a record with a non constant" + return "" + Record Nothing updates -> do + list' <- genRecordList updates + return $ lbrace <+> list' <+> rbrace + Parens expr' -> do + doc <- generate expr' + return . parens $ doc + -- Generates the list of key value pairs in a record + where + genRecordList updates = do + let (keys, values) = unzip updates + let docKeys = map text keys + docValues <- mapM generate values + return . hsep . punctuate "," . map (\(a, b) -> a <+> "=" <+> b) $ + zip docKeys docValues + -- Generates the list of declerations in a let expression + genLetList bindings = do + let (keys, values) = unzip bindings + docKeys <- mapM generate keys + docValues <- mapM generate values + return . vcat . map (\(a, b) -> a <+> "=" <+> b) $ + zip docKeys docValues + -- Generates the list of cases in a case statement + genCaseList options = do + let (keys, values) = unzip options + docKeys <- mapM generate keys + docValues <- sequence . map generate $ values + return . vcat . punctuate "\n" . map (\(a, b) -> a <+> "->" $+$ nest 4 b) $ + zip docKeys docValues + -- takes an expression and wraps it in parens + -- if required for nesting it in another expression + vop expr' = + case expr' of + Var _ -> generate expr' + Tuple _ -> generate expr' + List _ -> generate expr' + Int _ -> generate expr' + Float _ -> generate expr' + Under -> generate expr' + Str _ -> generate expr' + Record _ _ -> generate expr' + _ -> do + doc <- generate expr' + return . parens $ doc diff --git a/src/Elm/GenError.hs b/src/Elm/GenError.hs new file mode 100644 --- /dev/null +++ b/src/Elm/GenError.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE Strict #-} + +module Elm.GenError where + +import Protolude + +import Data.String + +data GenError + = WarningList [String] + | Error String + deriving (Eq, Show) + +instance Monoid GenError where + mappend (Error str) _ = Error str + mappend _ (Error str) = Error str + mappend (WarningList a) (WarningList b) = WarningList $ a ++ b + mempty = WarningList [] diff --git a/src/Elm/Import.hs b/src/Elm/Import.hs --- a/src/Elm/Import.hs +++ b/src/Elm/Import.hs @@ -1,61 +1,72 @@ {-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | Ast for expressing imports module Elm.Import where -import Text.PrettyPrint +import Protolude hiding (empty, (<>)) +import Control.Monad (mapM) +import Data.Maybe +import Data.String +import Elm.Classes +import Text.PrettyPrint + -- | Possible ways to expose an import data ImportType = Everything | Select [ImportItem] - | ExposeNothing -- | Possible ways to expose a sub import -data ImportItem +data ImportItem = Item String | ItemExposing String [String] | ItemEvery String -- | A full import -data Import = Import String (Maybe String) ImportType +data Import = Import String (Maybe String) (Maybe ImportType) -docItem :: ImportItem -> Doc -docItem item = - case item of - Item str -> - text str +instance Generate ImportItem where + generate item = + case item of + Item str -> + return . text $ str - ItemExposing name exposes -> - text name <> (parens . hsep . punctuate (text ",") . map text $ exposes) + ItemExposing str [] -> + return $ text str <> "()" - ItemEvery name -> - text name <> text "(..)" + ItemExposing str exposedItems -> + return $ text str <> (parens . hsep . punctuate "," . map text $ exposedItems) -exposingDoc :: ImportType -> Doc -exposingDoc importType = - case importType of - Everything -> - text "exposing (..)" + ItemEvery str -> + return $ text str <> "(..)" - ExposeNothing -> - empty +instance Generate ImportType where + generate item = + case item of + Everything -> + return "(..)" - Select imports -> - text "exposing" <+> (parens . hsep . punctuate (text ",") . map docItem $ imports) + Select [] -> do + return "()" -toDocI :: Import -> Doc -toDocI (Import name as exposing) = - text "import" <+> text name <+> asDoc <+> exposingDoc exposing + Select items -> do + docItems <- mapM generate items + return $ parens . hsep . punctuate "," $ docItems - where - asDoc = - case as of - Nothing -> - empty - Just str -> - text "as" <+> text str - - +instance Generate Import where + generate (Import name as exposing) = do + let asDoc = Data.Maybe.fromMaybe empty $ fmap (\str -> "as" <+> text str) $ as + exposingDoc <- + case exposing of + Nothing -> + return empty + Just e -> do + docE <- generate e + return $ "exposing" <+> docE + return $ "import" <+> text name <+> asDoc <+> exposingDoc diff --git a/src/Elm/Program.hs b/src/Elm/Program.hs --- a/src/Elm/Program.hs +++ b/src/Elm/Program.hs @@ -1,33 +1,48 @@ {-# OPTIONS_HADDOCK prune #-} +{-# OPTIONS_GHC -Wall -Werror #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- {-# LANGUAGE Safe #-} -- | Module for creating a program module Elm.Program where -import Elm.Import -import Elm.Decleration -import Text.PrettyPrint -import Data.String.Utils -import Data.List +import Protolude hiding (join) +import Control.Monad.Writer hiding (join) +import Data.List hiding (map) +import Data.String +import Data.String.Utils +import Elm.Classes +import Elm.Decleration +import Elm.GenError +import Elm.Import +import Text.PrettyPrint + -- | Program type data Program = Program String ImportType [Import] [Dec] -genProgram :: Program -> Doc -genProgram (Program name exports imports declerations) = - text "module" <+> text name <+> exposingDoc exports - $+$ (foldl ($+$) empty . map toDocI $ imports) - $+$ (foldl ($+$) empty . map toDocD $ declerations) +instance Generate Program where + generate (Program name exports imports declerations) = do + exportDoc <- generate exports + importDocs <- mapM generate imports + decDocs <- mapM generate declerations + return $ "module" <+> text name <+> "exposing" <+> exportDoc $+$ + vcat importDocs $+$ + vcat decDocs --- | Convert a program to a string of code -renderProgram :: Program -> String + +-- | Convert a program to a string of code with newlines between declerations +renderProgram :: Program -> (String, GenError) renderProgram program = - let - str = (render . genProgram $ program) ++ "\n" + let + (doc, parseError) = runWriter $ generate program + str = render doc in - join "\n" . map addNewline . split "\n" $ str + ((join "\n" . map addNewline . split "\n" $ str)++"\n", parseError) where addNewline line = - if (or $ map (\s -> isInfixOf s line) ["::", "type"]) then - "\n" ++ line + if (or $ map (\s -> isInfixOf s line) [":", "type"]) then + "\n\n" ++ line else line diff --git a/src/Elm/Type.hs b/src/Elm/Type.hs --- a/src/Elm/Type.hs +++ b/src/Elm/Type.hs @@ -1,12 +1,17 @@ {-# OPTIONS_HADDOCK prune #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- | Ast for declaring types module Elm.Type where -import Elm.Expression -import Text.PrettyPrint -import Data.Maybe +import Control.Monad.Writer (tell) +import Data.List (intersperse) +import Data.Maybe +import Data.String +import Elm.Classes +import Elm.Expression +import Elm.GenError +import Text.PrettyPrint -- | Data type to represent types data TypeDec @@ -14,63 +19,71 @@ = Params String [TypeDec] -- | A function type | TApp [TypeDec] - -- | A two tuple type - | TTuple2 TypeDec TypeDec + -- | A tuple type + | TTuple [TypeDec] -- | A record type | TRecord (Maybe String) [(String, TypeDec)] --- | Shortcut for declaring a type variable -tvar :: String -> TypeDec -tvar str = - Params str [] +instance IsString TypeDec where + fromString x = Params x [] -vopTApp :: TypeDec -> Doc -vopTApp t = - case t of - Params str types -> - toDocT $ Params str types - - TRecord main decs -> - toDocT $ TRecord main decs +instance Generate TypeDec where + generate typeDec = + case typeDec of + Params type_ params -> do + docParams <- mapM vopParam params + return $ text type_ <+> hsep docParams - _ -> - parens $ toDocT t + TApp decs -> do + docDecs <- mapM vopTApp decs + return . hsep . intersperse "->" $ docDecs -vopParam :: TypeDec -> Doc -vopParam t = - case t of - Params str [] -> - text str + TTuple [] -> do + return "()" - _ -> - parens $ toDocT t - + TTuple [item] -> do + tell $ WarningList ["Attempt to create a one item tuple"] + parens <$> generate item + TTuple items -> do + docItems <- mapM generate items + return . parens . hsep . punctuate "," $ docItems -toDocT :: TypeDec -> Doc -toDocT t = - case t of - Params p decs -> - text p <+> (hsep . map vopParam $ decs) + TRecord Nothing [] -> do + tell $ Error "Unable to create a record type with no base and no constraints" + return "" - TApp types -> - hsep . punctuate (text " ->") . map vopTApp $ types - - TTuple2 t1 t2 -> - lparen <> toDocT t1 <> comma <+> toDocT t2 <> rparen + TRecord (Just str) [] -> do + tell $ WarningList ["You are creating a record type from " ++ str ++ " with no constraints"] + return . text $ str - TRecord Nothing [] -> - "{}" + TRecord Nothing constraints -> do + cDoc <- generateTRecordList constraints + return $ lbrace <+> cDoc <+> rbrace - TRecord (Just main) [] -> - text main + TRecord (Just str) constraints -> do + cDoc <- generateTRecordList constraints + return $ lbrace <+> text str <+> text "|" <+> cDoc <+> rbrace - TRecord main decs -> - let - front = fmap (\x -> text x <+> "|") main - in - "{" <+> Data.Maybe.fromMaybe empty front - <+> (hsep . punctuate "," . map docDec $ decs) - <+> "}" - where - docDec (name, dec) = - text name <+> ":" <+> toDocT dec + where + generateTRecordList constraints = do + let (keys, values) = unzip constraints + let docKeys = map text keys + docValues <- mapM generate values + let docList = zip docKeys docValues + return . hsep . punctuate "," . map (\(a, b) -> a <+> ":" <+> b) $ docList + + vopParam type_ = + case type_ of + Params str [] -> + return . text $ str + + _ -> + parens <$> generate type_ + + vopTApp type_ = + case type_ of + TApp _ -> + parens <$> generate type_ + + _ -> + generate type_ diff --git a/test/Renderer.hs b/test/Renderer.hs new file mode 100644 --- /dev/null +++ b/test/Renderer.hs @@ -0,0 +1,28 @@ +module Renderer where + +import Control.Monad.Writer +import Elm.Classes +import Elm.Expression +import Elm.GenError +import Text.PrettyPrint + +renderExpr :: Expr -> String +renderExpr expr = + let + (doc, err) = runWriter . generate $ expr + in + if err == WarningList [] then + Text.PrettyPrint.render doc + else + error $ "Generation Error: " ++ show err + + +render :: (Generate a) => a -> String +render expr = + let + (doc, err) = runWriter . generate $ expr + in + if err == WarningList [] then + Text.PrettyPrint.render doc + else + error $ "Generation Error: " ++ show err diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,324 +1,332 @@ {-# LANGUAGE OverloadedStrings #-} -module Main where - -import Test.HUnit -import Elm.Expression -import Elm.Type -import Elm.Decleration -import Elm.Import -import Elm.Program -import Text.PrettyPrint hiding (Str) -import Control.Monad - -assertString :: String -> String -> String -> Assertion -assertString preface expected actual = - unless (actual == expected) (assertFailure msg) - where msg = (if null preface then "" else preface ++ "\n") ++ - "expected:\n\n" ++ expected ++ "\n but got:\n\n" ++ actual ++ - "\n" ++ (show . length $ expected) ++ " - " - ++ (show . length $ actual) - -testRender ast = - (render . toDoc $ ast) ++ "\n" - -testRenderDec ast = - (render . toDocD $ ast) ++ "\n" - -testApp = - [ do - assertEqual "No arguments" (text "f") (toDoc $ App "f" []) - , do - assertEqual "single var" (text "f a") (toDoc $ App "f" [App "a" []]) - assertEqual "two vars" (text "f a b") (toDoc $ App "f" [App "a" [], App "b" []]) - , do - assertEqual "parens" (text "f (a b)") (toDoc $ App "f" [App "a" [App "b" []]]) - ] - -testCase = - [ do - text <- readFile "test/case1.txt" - let - ast = - Case (App "color" []) - [ (App "Red" [], Str "red") - , (App "Blue" [], Str "blue") - , (App "Green" [], Str "green") - ] - assertEqual "colors" text $ testRender ast - , do - text <- readFile "test/case2.txt" - let - ast = - Case (App "m" []) - [ (App "Just" [var "data"], var "data") - , (var "Nothing", Str "") - ] - assertEqual "maybe" text $ testRender ast - , do - text <- readFile "test/case3.txt" - let - ast = - Case (Tuple2 (var "a") (var "b")) - [ (Tuple2 (Int 1) (Int 2), BoolTrue) - , (Under, BoolFalse) - ] - assertEqual "tuple" text $ testRender ast - , do - text <- readFile "test/case4.txt" - let - ast = - Case (App "f" [var "x"]) - [ (BoolTrue, Str "true") - , (BoolFalse, Str "false") - ] - - assertEqual "application" text $ testRender ast - , do - text <- readFile "test/case5.txt" - let - ast = - Case (var "b") - [ (BoolTrue, - Let (Str "true") - [ (Under, App "Debug.log" [Str "logging", Str "its true"]) - ]) - , (BoolFalse, - Let (Str "false") - [ (Under, App "Debug.log" [Str "logging", Str "its false"]) - ]) - ] - - assertEqual "let in case" text $ testRender ast - ] - -testLet = - [ do - text <- readFile "test/let1.txt" - let - ast = - Let (var "a") - [ (var "a", Int 5) ] - - assertEqual "application" text $ testRender ast - , do - text <- readFile "test/let2.txt" - let - ast = - Let (App "f" [var "a", var "b"]) - [ (var "a", Int 5) - , (var "b", Int 6) - ] - assertEqual "more variables" text $ testRender ast - ] - -testOp = - [ do - assertEqual "plus" (text "a + b") (toDoc $ Op "+" (var "a") (var "b")) - assertEqual "compose" (text "a <<< b") (toDoc $ Op "<<<" (var "a") (var "b")) - assertEqual "longer names" (text "abc >>> def") - (toDoc $ Op ">>>" (var "abc") (var "def")) - assertEqual "parens" (text "(f a) + (g b)") - (toDoc $ (Op "+" (App "f" [var "a"]) (App "g" [var "b"]))) - ] - -testList = - [ do - assertEqual "empty" (text "[]") (toDoc $ List []) - , do - assertEqual "some stuff" (text "[1, 2, 3]") - (toDoc $ List [Int 1, Int 2, Int 3]) - ] +import Control.Monad.Writer +import Elm.Classes +import Elm.Decleration +import Elm.Expression +import Elm.GenError +import Elm.Import +import Elm.Program +import Elm.Type +import Renderer +import Test.Hspec +import Text.PrettyPrint hiding (Str, render) -testRecord = - [ do - assertEqual "empty" (text "{}") (toDoc $ Record Nothing []) - assertEqual "no sets" (text "a") (toDoc $ Record (Just $ var "a") []) - assertEqual "some stuff" - (text "{ a | b = 5 }") - (toDoc $ Record (Just $ var "a") [("b", Int 5)]) - ] +main = hspec $ do + describe "Setup" $ do + it "Should work" $ do + 5 `shouldBe` 5 + describe "Expression" $ do + describe "Bool" $ do + it "Should render true properly" $ do + let expr = Bool True + renderExpr expr `shouldBe` "True" + it "Should render false properly" $ do + let expr = Bool False + renderExpr expr `shouldBe` "False" + describe "Int" $ do + it "Should work" $ do + renderExpr (Int 5) `shouldBe` "5" + describe "Float" $ do + it "Should work" $ do + renderExpr (Float 1.2) `shouldBe` "1.2" + describe "String" $ do + it "Should work" $ do + renderExpr (Str "hello") `shouldBe` "\"hello\"" + describe "Tuple" $ do + it "Should work for 0 tuples" $ do + renderExpr (Tuple []) `shouldBe` "()" + it "Should work for larger tuples" $ do + renderExpr (Tuple [Int 5, Int 6]) `shouldBe` "( 5, 6 )" + renderExpr (Tuple [Int 2, Float 2.5]) `shouldBe` "( 2, 2.5 )" + describe "Var" $ do + it "Should work" $ do + renderExpr (Var "a") `shouldBe` "a" + renderExpr (Var "abc") `shouldBe` "abc" + it "Should work with overloadedstrings" $ do + renderExpr "a" `shouldBe` "a" + renderExpr "abc" `shouldBe` "abc" + it "Should error on an empty string" $ do + (runWriter . generate $ Var "") `shouldBe` (text "", Error "An empty string is not a valid variable name") + it "Should wrap operators in parens" $ do + pending + it "Should only allow operators with valid characters" $ do + pending + it "Should only allow variables with valid characters" $ do + pending + describe "Under" $ do + it "Does this I guess" $ do + renderExpr Under `shouldBe` "_" + describe "List" $ do + it "Should work for empty lists" $ do + renderExpr (List []) `shouldBe` "[]" + it "Should work for single item lists" $ do + renderExpr (List ["a"]) `shouldBe` "[a]" + it "Should work for multi item lists" $ do + renderExpr (List ["a", "b", "c"]) `shouldBe` "[a, b, c]" + it "Should work with overloaded lists" $ do + renderExpr (List ["a", "b", "c"]) `shouldBe` "[a, b, c]" + describe "Function Application" $ do + it "Should work for 0 params" $ do + renderExpr (App ["a"]) `shouldBe` "a" + it "Should work for multiple params" $ do + renderExpr (App ["a", "b", "c"]) `shouldBe` "a b c" + renderExpr (App ["a", Int 5, "b", Int 7]) `shouldBe` "a 5 b 7" + it "Should nest properly" $ do + renderExpr (App ["a", App ["b", "c"]]) `shouldBe` "a (b c)" + describe "Inline operators" $ do + it "Should work" $ do + renderExpr (Op "+" "a" "b") `shouldBe` "a + b" + it "Should error on invalid operator characters" $ do + pending + describe "Record" $ do + it "Should work when empty" $ do + renderExpr (Record Nothing []) `shouldBe` "{}" + it "Should work with key value pairs" $ do + renderExpr (Record Nothing [("a", Int 5), ("b", Int 6)]) + `shouldBe` "{ a = 5, b = 6 }" + it "Should allow updates" $ do + renderExpr (Record (Just "a") [("b", Int 5)]) + `shouldBe` "{ a | b = 5 }" + it "Should warn here" $ do + (runWriter . generate $ Record (Just "data") []) + `shouldBe` ("data", WarningList ["Trying to update record data with no changed fields"]) + it "Should error here" $ do + (runWriter . generate $ Record (Just $ App ["f", Int 5]) []) + `shouldBe` ("", Error "You are unable to update a record with a non constant") + describe "Let" $ do + it "Should work with one dec" $ do + text <- liftIO . readFile $ "test/spec/let1.txt" + let + ast = Let "a" [("a", Int 5)] + renderExpr ast ++ "\n" `shouldBe` text + it "Should work with more than one dec" $ do + text <- liftIO . readFile $ "test/spec/let2.txt" + let + ast = Let (Op "+" "a" "b") [("a", Int 5), ("b", Int 6)] + renderExpr ast ++ "\n" `shouldBe` text + it "Should error with zero declerations" $ do + (runWriter . generate $ Let "a" []) + `shouldBe` ("", Error "Unable to create let expression with 0 bindings") + describe "Case" $ do + it "Should work" $ do + text <- liftIO . readFile $ "test/spec/case1.txt" + let + ast = + Case "m" + [(App ["Just", "x"], "x") + ,("Nothing", Int 0) + ] + renderExpr ast ++ "\n" `shouldBe` text + it "Should generate an error with no cases" $ do + let + ast = Case "m" [] + (runWriter . generate $ ast) + `shouldBe` ("", Error "Unable to create case expression with 0 cases") -testType = - [ do - assertEqual "simple" (text "a") (toDocT $ tvar "a") - assertEqual "param" (text "Maybe a") (toDocT $ Params "Maybe" [tvar "a"]) - assertEqual "multi param" (text "Result String Int") - (toDocT $ Params "Result" [tvar "String", tvar "Int"]) - , do - assertEqual "app" (text "a -> b") - (toDocT $ TApp [tvar "a", tvar "b"]) - assertEqual "more app" (text "a -> b -> c") - (toDocT $ TApp [tvar "a", tvar "b", tvar "c"]) - assertEqual "nested app" (text "(a -> b) -> a -> b") - (toDocT $ TApp [TApp [tvar "a", tvar "b"], tvar "a", tvar "b"]) - , do - assertEqual "more nested stuff" (text "Maybe (a -> b) String") - (toDocT $ Params "Maybe" [TApp [tvar "a", tvar "b"], tvar "String"]) - assertEqual "alternate nesting" (text "Maybe (Maybe a)") - (toDocT $ Params "Maybe" [Params "Maybe" [tvar "a"]]) - , do - assertEqual "record types" (text "{}") (toDocT $ TRecord Nothing []) - assertEqual "memier record types" - (text "{ a : Int, b : Int }") - (toDocT $ TRecord Nothing [("a", tvar "Int"), ("b", tvar "Int")]) - assertEqual "the dankest rarest memes" - (text "{ a | b : Int }") - (toDocT $ TRecord (Just "a") [("b", tvar "Int")]) - ] + describe "Type" $ do + describe "Params" $ do + it "Should work for without params" $ do + render (Params "a" []) + `shouldBe` "a" + it "Should work with params" $ do + render (Params "a" [Params "b" []]) + `shouldBe` "a b" + it "Should put params in parens if needed" $ do + render (Params "a" [Params "b" [Params "c" []]]) + `shouldBe` "a (b c)" -testDec = - [ do - text <- readFile "test/dec.txt" - let - ast = - Dec - "withDefault" - (TApp [tvar "a", Params "Maybe" [tvar "a"], tvar "a"]) - [var "default", var "maybe"] - (Case - (var "maybe") - [ (App "Just" [var "data"], var "data") - , (var "Nothing", var "default") - ]) - assertEqual "test" text $ testRenderDec ast - ] + describe "TApp" $ do + it "Should work" $ do + render (TApp [Params "a" [], Params "b" []]) + `shouldBe` "a -> b" -testDecType = - [ do - assertEqual "what even goes here?" (text "type User = User String") - (toDocD $ DecType "User" [] [("User", [tvar "String"])]) - assertEqual "que??" (text "type Color = Red | Blue | Green") - (toDocD $ DecType "Color" [] [("Red", []), ("Blue", []), ("Green", [])]) - assertEqual ":(" (text "type Data = DataA (Maybe String) | DataB (String -> Int)") - (toDocD $ DecType "Data" [] - [ ("DataA", [Params "Maybe" [tvar "String"]]) - , ("DataB", [TApp [tvar "String", tvar "Int"]]) - ]) - assertEqual "noh" (text "type Maybe a = Nothing | Just a") - (toDocD $ DecType "Maybe" ["a"] - [ ("Nothing", []) - , ("Just", [tvar "a"]) - ]) - ] + it "Should put nested tapps in parens" $ do + render (TApp [Params "a" [], TApp [Params "a" [], Params "b" []]]) + `shouldBe` "a -> (a -> b)" -testDecTypeAlias = - [ do - assertEqual "this stuff" (text "type alias Model = Int") - (toDocD $ DecTypeAlias "Model" [] (tvar "Int")) - assertEqual "dubple" (text "type alias Duple a = (a, a)") - (toDocD $ DecTypeAlias "Duple" ["a"] $ TTuple2 (tvar "a") (tvar "a")) - ] + describe "TTuple" $ do + it "Should work for unit" $ do + render (TTuple []) `shouldBe` "()" -testImport = - [ do - assertEqual "wut" (text "import List") (toDocI $ Import "List" Nothing ExposeNothing) - assertEqual "wut" (text "import List as L") (toDocI $ Import "List" (Just "L") ExposeNothing) - assertEqual "wut" (text "import List exposing (map)") (toDocI $ Import "List" Nothing $ Select [Item "map"]) - assertEqual "wut" (text "import List as L exposing (map)") - (toDocI $ Import "List" (Just "L") $ Select [Item "map"]) - assertEqual "wut" (text "import List exposing (List(..))") - (toDocI $ Import "List" Nothing $ Select [ItemEvery "List"]) - assertEqual "wut" (text "import List exposing (List(Cons))") - (toDocI $ Import "List" Nothing $ Select [ItemExposing "List" ["Cons"]]) - ] + it "Should return the value and warn with a one item tuple" $ do + let + ast = + TTuple [Params "a" []] + (runWriter . generate $ ast) + `shouldBe` ("(a)", WarningList ["Attempt to create a one item tuple"]) + it "Should work for multiple item tuples" $ do + render (TTuple [Params "a" [], Params "b" []]) + `shouldBe` "(a, b)" -testProgram = - [ do - file <- readFile "test/program1.elm" + describe "TRecord" $ do + it "Should error when passed nothing" $ do + let + ast = + TRecord Nothing [] + (runWriter . generate $ ast) + `shouldBe` ("", Error "Unable to create a record type with no base and no constraints") - let - ast = - Program - "Maybe" - (Select - [ ItemExposing "Maybe" ["Just", "Nothing"] - , Item "andThen" - , Item "map" - , Item "map2" - , Item "map3" - , Item "map4" - , Item "map5" - , Item "withDefault" - ]) + it "Should warn when there are no constraints" $ do + let + ast = + TRecord (Just "a") [] + (runWriter . generate $ ast) + `shouldBe` ("a", WarningList ["You are creating a record type from a with no constraints"]) + it "Should work with no base" $ do + let + ast = + TRecord Nothing + [ ("a", Params "Int" []) + , ("b", Params "Int" []) + ] + render ast `shouldBe` "{ a : Int, b : Int }" - [] - [ DecType "Maybe" ["a"] [ ("Nothing", []), ("Just", [tvar "a"]) ] - , Dec "withDefault" - (TApp [tvar "a", Params "Maybe" [tvar "a"], tvar "a"]) - [var "default", var "maybe"] - (Case (var "maybe") - [ (App "Just" [var "value"], var "value") - , (var "Nothing", var "default") - ]) - , Dec "map" - (TApp - [ TApp [tvar "a", tvar "b"] - , Params "Maybe" [tvar "a"] - , Params "Maybe" [tvar "b"] - ]) - [var "f", var "maybe"] - (Case (var "maybe") - [ (App "Just" [var "value"], App "Just" [App "f" [var "value"]]) - , (var "Nothing", var "Nothing") - ]) - , Dec "map2" - (TApp - [ TApp [tvar "a", tvar "b", tvar "value"] - , Params "Maybe" [tvar "a"] - , Params "Maybe" [tvar "b"] - , Params "Maybe" [tvar "value"] - ]) - [var "func", var "ma", var "mb"] - (Case (Tuple2 (var "ma") (var "mb")) - [ (Tuple2 (App "Just" [var "a"]) (App "Just" [var "b"]) - , App "Just" [App "func" [var "a", var "b"]]) - , (var "_", var "Nothing") - ]) - , Dec "map3" - (TApp - [ TApp - [ tvar "a" - , tvar "b" - , tvar "c" - , tvar "value" - ] - , Params "Maybe" [tvar "a"] - , Params "Maybe" [tvar "b"] - , Params "Maybe" [tvar "c"] - , Params "Maybe" [tvar "value"] + it "Should work with a base" $ do + let + ast = + TRecord (Just "a") + [ ("b", Params "Int" []) + , ("c", Params "Int" []) + ] + render ast `shouldBe` "{ a | b : Int, c : Int }" + describe "Import" $ do + describe "ImportItem" $ do + it "Should work for single items" $ do + render (Item "Maybe") + `shouldBe` "Maybe" + it "Should work for sub importing" $ do + render (ItemExposing "Maybe" ["Just", "Nothing"]) + `shouldBe` "Maybe(Just, Nothing)" + it "Should working for sub importing everything" $ do + render (ItemEvery "Maybe") + `shouldBe` "Maybe(..)" + describe "ImportType" $ do + it "Should properly select everything" $ do + render (Everything) `shouldBe` "(..)" + it "Should properly select only types" $ do + render (Select []) `shouldBe` "()" + it "Should properly select items" $ do + render (Select [Item "Just", Item "withDefault"]) + `shouldBe` "(Just, withDefault)" + render (Select [ItemEvery "Just", Item "withDefault"]) + `shouldBe` "(Just(..), withDefault)" + describe "Import" $ do + it "Should import stuff" $ do + render (Import "List" Nothing Nothing) + `shouldBe` "import List" + it "Should render with an alias" $ do + render (Import "Maybe" (Just "M") Nothing) + `shouldBe` "import Maybe as M" + it "Should expose from the imports" $ do + render (Import "Maybe" Nothing $ Just $ Select [Item "withDefault"]) + `shouldBe` "import Maybe exposing (withDefault)" + describe "Dec" $ do + it "Should work for simple delcerations" $ do + let + ast = + Dec "add5" + (TApp ["Int", "Int"]) + [Var "x"] + (Op "+" (Var "x") (Int 5)) + file <- readFile "test/spec/dec1.txt" + render ast ++ "\n" `shouldBe` file + it "Should work for more complex declerations" $ do + let + ast = + Dec "withDefault" + (TApp ["a", Params "Maybe" ["a"], "a"]) + ["default", "m"] + (Case "m" + [ (App ["Just", "x"], "x") + , ("Nothing", "default") + ]) + file <- readFile "test/spec/dec2.txt" + render ast ++ "\n" `shouldBe` file + it "Should properly handle type declerations" $ do + -- \_(*_*)_/ + let + ast = + DecType "Maybe" + ["a"] + [ ("Nothing", []) + , ("Just", ["a"]) + ] + file <- readFile "test/spec/dec3.txt" + render ast ++ "\n" `shouldBe` file + it "Should properly handle type aliases" $ do + let + ast = + DecTypeAlias "Model" ["a"] (Params "Maybe" ["a"]) + file <- readFile "test/spec/dec4.txt" + render ast ++ "\n" `shouldBe` file + describe "Program" $ do + it "Should work" $ do + let + ast = + Program "Maybe" + (Select + [ ItemExposing "Maybe" ["Just", "Nothing"] + , Item "andThen" + , Item "map" + , Item "map2" + , Item "map3" + , Item "map4" + , Item "map5" + , Item "withDefault" ]) - [var "func", var "ma", var "mb", var "mc"] - (Case (Tuple3 (var "ma") (var "mb") (var "mc")) - [ (Tuple3 - (App "Just" [var "a"]) - (App "Just" [var "b"]) - (App "Just" [var "c"]), - (App "Just" [App "func" [var "a", var "b", var "c"]])) - , (var "_", var "Nothing") + [] + [ DecType "Maybe" ["a"] + [ ("Nothing", []) + , ("Just", ["a"]) ] - ) - - - ] - Main.assertString "meh" file $ renderProgram ast - ] - -tests = - TestList - [ "test var" ~: testApp - , "test case" ~: testCase - , "test let" ~: testLet - , "test op" ~: testOp - , "test list" ~: testList - , "test record" ~: testRecord - , "test type" ~: testType - , "test dec type alias" ~: testDecTypeAlias - , "test dec type" ~: testDecType - , "test dec" ~: testDec - , "test import" ~: testImport - , "test program" ~: testProgram - ] - -main :: IO Counts -main = runTestTT tests + , Dec "withDefault" + (TApp ["a", Params "Maybe" ["a"], "a"]) + ["default", "maybe"] + (Case "maybe" + [ (App ["Just", "value"], "value") + , ("Nothing", "default") + ]) + , Dec "map" + (TApp [TApp ["a", "b"], Params "Maybe" ["a"], Params "Maybe" ["b"]]) + ["f", "maybe"] + (Case "maybe" + [ (App ["Just", "value"], App ["Just", App ["f", "value"]]) + , ("Nothing", "Nothing") + ]) + , Dec "map2" + (TApp + [ TApp ["a", "b", "value"] + , Params "Maybe" ["a"] + , Params "Maybe" ["b"] + , Params "Maybe" ["value"] + ]) + ["func", "ma", "mb"] + (Case (Tuple ["ma", "mb"]) + [ (Tuple [App ["Just", "a"], App ["Just", "b"]], + App ["Just", App ["func", "a", "b"]]) + , (Under, "Nothing") + ]) + , Dec "map3" + (TApp + [ TApp ["a", "b", "c", "value"] + , Params "Maybe" ["a"] + , Params "Maybe" ["b"] + , Params "Maybe" ["c"] + , Params "Maybe" ["value"] + ]) + ["func", "ma", "mb", "mc"] + (Case (Tuple ["ma", "mb", "mc"]) + [ (Tuple + [ App ["Just", "a"] + , App ["Just", "b"] + , App ["Just", "c"] + ], + App ["Just", App ["func", "a", "b", "c"]]) + , (Under, "Nothing") + ]) + ] + file <- readFile "test/program1.elm" + let (str, err) = renderProgram ast + err `shouldBe` WarningList [] + str `shouldBe` file