diff --git a/madlang.cabal b/madlang.cabal --- a/madlang.cabal +++ b/madlang.cabal @@ -1,5 +1,5 @@ name: madlang -version: 2.4.0.2 +version: 2.4.1.0 synopsis: Randomized templating language DSL description: Please see README.md homepage: https://github.com/vmchale/madlang#readme @@ -17,10 +17,15 @@ , demo/*.mad , default.nix , release.nix - , stack.yaml , bash/mkCompletions cabal-version: >=1.10 +Flag development { + Description: Turn on '-Werror' + Default: False + Manual: True +} + Flag llvm-fast { Description: Enable build with llvm backend (produces a faster executable) Default: False @@ -31,11 +36,6 @@ Default: False } -Flag gold { - Description: Enable the gold linker for faster build times - Default: True -} - library hs-source-dirs: src exposed-modules: Text.Madlibs @@ -50,7 +50,7 @@ , Text.Madlibs.Cata.Display , Text.Madlibs.Exec.Main , Paths_madlang - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.8 && < 5 , megaparsec >= 6.0 , text , optparse-applicative @@ -58,7 +58,6 @@ , MonadRandom , composition , composition-extra - -- , dhall , directory , file-embed , random-shuffle @@ -71,10 +70,9 @@ , DeriveGeneric , DeriveFunctor , DeriveAnyClass - if flag(gold) - ghc-options: -optl-fuse-ld=gold - ld-options: -fuse-ld=gold - ghc-options: -fwarn-unused-imports + if flag(development) + ghc-options: -Werror + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates executable madlang if flag(library) @@ -85,10 +83,9 @@ main-is: Main.hs if flag(llvm-fast) ghc-options: -fllvm -O3 -optlo-O3 -opta-march=native -opta-mtune=native - if flag(gold) - ghc-options: -optl-fuse-ld=gold - ld-options: -fuse-ld=gold - ghc-options: -threaded -rtsopts + if flag(development) + ghc-options: -Werror + ghc-options: -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates build-depends: base , madlang default-language: Haskell2010 @@ -104,10 +101,9 @@ , text if flag(llvm-fast) ghc-options: -fllvm -optlo-O3 -O3 -fwarn-unused-imports - if flag(gold) - ghc-options: -optl-fuse-ld=gold - ld-options: -fuse-ld=gold - ghc-options: -threaded -rtsopts -with-rtsopts=-N -O3 -fwarn-unused-imports + if flag(development) + ghc-options: -Werror + ghc-options: -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -O3 default-language: Haskell2010 test-suite madlang-test @@ -122,10 +118,9 @@ , text , mtl , hspec-megaparsec - if flag(gold) - ghc-options: -optl-fuse-ld=gold - ld-options: -fuse-ld=gold - ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-unused-imports + if flag(development) + ghc-options: -Werror + ghc-options: -threaded -rtsopts -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -with-rtsopts=-N default-language: Haskell2010 source-repository head diff --git a/src/Text/Madlibs/Ana/ParseUtils.hs b/src/Text/Madlibs/Ana/ParseUtils.hs --- a/src/Text/Madlibs/Ana/ParseUtils.hs +++ b/src/Text/Madlibs/Ana/ParseUtils.hs @@ -16,6 +16,8 @@ import Data.List import qualified Data.Map as M import qualified Data.Text as T +import Debug.Trace +import Debug.Trace import System.Random.Shuffle import Text.Madlibs.Cata.SemErr import Text.Madlibs.Internal.Types @@ -97,6 +99,13 @@ orderHelper :: Key -> [(Prob, [PreTok])] -> Bool orderHelper key = any (\pair -> key `elem` (map unTok . snd $ pair)) +hasNoDeps :: [(Prob, [PreTok])] -> Bool +hasNoDeps = all isPreTok . concatMap snd + where isPreTok PreTok{} = True + isPreTok x = False + +-- TODO 'somethingelse' shouldn't be less than 'athirdthing'!! + -- | Ordering on the keys to account for dependency orderKeys :: (Key, [(Prob, [PreTok])]) -> (Key, [(Prob, [PreTok])]) -> Ordering orderKeys (key1, l1) (key2, l2) @@ -104,9 +113,11 @@ | key2 == "Return" = LT | orderHelper key1 l2 = LT | orderHelper key2 l1 = GT - | any (flip orderHelper l1) (flatten l2) = LT -- FIXME needs to not default to `EQ` when transitive dependencies are a thing. + | any (flip orderHelper l1) (flatten l2) = LT | any (flip orderHelper l2) (flatten l1) = GT - | otherwise = EQ + | hasNoDeps l1 = LT + | hasNoDeps l2 = GT + | otherwise = EQ -- FIXME transitive dependencies flatten :: [(Prob, [PreTok])] -> [Key] flatten = concatMap (map unTok . snd) diff --git a/src/Text/Madlibs/Cata/SemErr.hs b/src/Text/Madlibs/Cata/SemErr.hs --- a/src/Text/Madlibs/Cata/SemErr.hs +++ b/src/Text/Madlibs/Cata/SemErr.hs @@ -34,7 +34,7 @@ show (DoubleDefinition f) = show $ semErrStart <> text "File contains two declarations of:" <> indent 4 (yellow (text' f)) show NoReturn = show $ semErrStart <> text "File must contain exactly one declaration of :return" show (NoContext f1) = show $ semErrStart <> text "Call in function: " <> indent 4 (yellow (text' f1)) <> "which is not in scope" - show (CircularFunctionCalls f1 f2) = show $ semErrStart <> text "Function" indent 4 (yellow (text' f2)) <> text' " refers to a function" indent 4 (yellow (text' f1)) <> text' ", which is not in scope." indent 2 (text' "This may be due to circular function dependecies.") + show (CircularFunctionCalls f1 f2) = show $ semErrStart <> text "Function" indent 4 (yellow (text' f2)) <> text' " refers to a function" indent 4 (yellow (text' f1)) <> text' ", which is not in scope." indent 2 (text' "This may be due to a circular function dependecy.") show (InsufficientArgs i j) = show $ semErrStart <> text "Insufficent arguments from the command line; given " <> (text . show $ i) <> ", expected at least " <> (text . show $ j) -- | Derived via our show instance; diff --git a/src/Text/Madlibs/Exec/Main.hs b/src/Text/Madlibs/Exec/Main.hs --- a/src/Text/Madlibs/Exec/Main.hs +++ b/src/Text/Madlibs/Exec/Main.hs @@ -2,19 +2,19 @@ module Text.Madlibs.Exec.Main ( runMadlang ) where -import Control.Monad -import Text.Madlibs.Ana.Resolve -import Text.Madlibs.Cata.Display -import Text.Madlibs.Internal.Utils -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Text.Megaparsec -import Options.Applicative hiding (ParseError) -import Data.Monoid -import Data.Maybe -import System.Directory -import Paths_madlang -import Data.Version +import Control.Monad +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.Version +import Options.Applicative hiding (ParseError) +import Paths_madlang +import System.Directory +import Text.Madlibs.Ana.Resolve +import Text.Madlibs.Cata.Display +import Text.Madlibs.Internal.Utils +import Text.Megaparsec -- | datatype for the program data Program = Program { sub :: Subcommand } @@ -42,7 +42,7 @@ <> help "Number of times to repeat")) <*> (many $ strOption (short 'i' - <> metavar "VAR" + <> metavar "VAR" <> help "command-line inputs to the template.")) <*> (argument str (metavar "FILEPATH" @@ -75,7 +75,7 @@ -- > $ madlang run example.mad -- > some text generated runMadlang :: IO () -runMadlang = execParser wrapper >>= template +runMadlang = execParser wrapper >>= template versionInfo = infoOption ("madlang version: " ++ showVersion version) (short 'v' <> long "version" <> help "Show version") @@ -95,8 +95,8 @@ case sub rec of (Run reps _ _) -> do parsed <- parseFile ins "" filepath - replicateM_ (fromMaybe 1 reps) $ runFile ins filepath >>= TIO.putStrLn - (Debug _) -> putStr . (either show displayTree) =<< makeTree ins "" filepath + replicateM_ (fromMaybe 1 reps) $ runFile ins filepath >>= TIO.putStrLn + (Debug _) -> putStr . (either show displayTree) =<< makeTree ins "" filepath (Lint _ _) -> do parsed <- parseFile ins "" filepath putStrLn $ either parseErrorPretty (const "No syntax errors found.") parsed diff --git a/src/Text/Madlibs/Internal/Types.hs b/src/Text/Madlibs/Internal/Types.hs --- a/src/Text/Madlibs/Internal/Types.hs +++ b/src/Text/Madlibs/Internal/Types.hs @@ -6,6 +6,7 @@ import Control.Monad.State import Data.Function +import Data.Monoid import qualified Data.Text as T import Lens.Micro @@ -19,7 +20,7 @@ data PreTok = Name T.Text (T.Text -> T.Text) | PreTok T.Text instance Show PreTok where - show (Name t _) = show t + show (Name t _) = show ("lambda: " <> t) show (PreTok t) = show t instance Eq PreTok where @@ -42,8 +43,8 @@ instance Monoid RandTok where mempty = Value "" mappend (Value v1) (Value v2) = Value (T.append v1 v2) - mappend (List l1) v@(Value v1) = List $ map (over (_2) (`mappend` v)) l1 - mappend v@(Value v2) (List l2) = List $ map (over (_2) (v `mappend`)) l2 + mappend (List l1) v@(Value v1) = List $ map (over _2 (`mappend` v)) l1 + mappend v@(Value v2) (List l2) = List $ map (over _2 (mappend v)) l2 mappend l@(List l1) (List l2) = List [ (p, l `mappend` tok) | (p,tok) <- l2 ] -- TODO make this a map instead of keys for faster parse. @@ -52,4 +53,4 @@ -- | Compare inside the state monad using only the underlying objects instance (Eq a) => Eq (Context a) where - (==) = (on (==) (flip evalState [])) + (==) = on (==) (flip evalState []) diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,6 +0,0 @@ -resolver: lts-9.0 -packages: -- . -extra-deps: [] -flags: {} -extra-package-dbs: []