ngws
/
mad
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Don't lift types 

Not needed since we only care about the final IO () result.
This commit is contained in:
Niels G. W. Serup 2024-10-09 23:12:01 +02:00
parent 6c6dd510d9
commit 418ebcb60f
No known key found for this signature in database
GPG Key ID: 38EEEBCE67324F19
11 changed files with 47 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
byg/byg.cabal
View File

@ -51,5 +51,4 @@ executable byg
build-depends:
base >=4.14 && <4.20
, text
, template-haskell
, byg

26
byg/src/Function.hs
View File

@ -29,10 +29,9 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Text.Pandoc as P
import qualified Text.Blaze.Html.Renderer.Text as B
import Language.Haskell.TH.Syntax (Lift)
data ConcatStrings = ConcatStrings deriving (Show, Lift)
data ConcatStrings = ConcatStrings deriving Show
instance IsFunction ConcatStrings [String] String where
evalFunction ConcatStrings = StringWrapper . concatMap unStringWrapper
@ -40,7 +39,7 @@ concatStrings :: TokenableTo [String] a => a -> DepGenM (Token String)
concatStrings a = runFunction ConcatStrings =<< toToken a
data ConcatTexts = ConcatTexts deriving (Show, Lift)
data ConcatTexts = ConcatTexts deriving Show
instance IsFunction ConcatTexts [Text] Text where
evalFunction ConcatTexts = T.concat
@ -48,7 +47,7 @@ concatTexts :: TokenableTo [Text] a => a -> DepGenM (Token Text)
concatTexts a = runFunction ConcatTexts =<< toToken a
data JoinPaths = JoinPaths deriving (Show, Lift)
data JoinPaths = JoinPaths deriving Show
instance IsFunction JoinPaths (FilePath, FilePath) FilePath where
evalFunction JoinPaths (StringWrapper s0, StringWrapper s1) = StringWrapper (s0 ++ "/" ++ s1)
@ -56,7 +55,7 @@ joinPaths :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGe
joinPaths a b = runFunction JoinPaths =<< TupleToken <$> toToken a <*> toToken b
data FileComponents = FileComponents deriving (Show, Lift)
data FileComponents = FileComponents deriving Show
instance IsFunction FileComponents FilePath (String, String) where
evalFunction FileComponents (StringWrapper s) =
let (lastRev, firstRev) = span (/= '.') $ reverse s
@ -69,7 +68,7 @@ fileComponents :: TokenableTo FilePath a => a -> DepGenM (Token (String, String)
fileComponents a = runFunction FileComponents =<< toToken a
data LowerString = LowerString deriving (Show, Lift)
data LowerString = LowerString deriving Show
instance IsFunction LowerString String String where
evalFunction LowerString (StringWrapper s) = StringWrapper (map toLower s)
@ -79,15 +78,14 @@ lowerString a = runFunction LowerString =<< toToken a
data ElemOf a where ElemOf :: WitnessFor w a => w -> ElemOf a
deriving instance Show (ElemOf a)
deriving instance Lift (ElemOf a)
instance (Show a, Lift a, Valuable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where
instance (Show a, Valuable a, Eq a) => IsFunction (ElemOf a) (a, [a]) Bool where
evalFunction (ElemOf _) (y, ys) = y `elem` ys
elemOf :: forall t w a b. (Show t, Lift t, Valuable t, Eq t, TokenableTo t a, TokenableTo [t] b, WitnessFor w t) => a -> b -> DepGenM (Token Bool)
elemOf :: forall t w a b. (Show t, Valuable t, Eq t, TokenableTo t a, TokenableTo [t] b, WitnessFor w t) => a -> b -> DepGenM (Token Bool)
elemOf a b = runFunction (ElemOf (witnessValue :: w)) =<< toTupleToken a b
data MakeTemplate = MakeTemplate deriving (Show, Lift)
data MakeTemplate = MakeTemplate deriving Show
instance IsFunction MakeTemplate (Text, Text) Template where
evalFunction MakeTemplate (t, c) =
let (beforeContent, after) = T.breakOn c t
@ -98,7 +96,7 @@ makeTemplate :: (TokenableTo Text a, TokenableTo Text b) => a -> b -> DepGenM (T
makeTemplate a b = runFunction MakeTemplate =<< toTupleToken a b
data ApplyTemplate = ApplyTemplate deriving (Show, Lift)
data ApplyTemplate = ApplyTemplate deriving Show
instance IsFunction ApplyTemplate (Template, Text) Text where
evalFunction ApplyTemplate (TemplateParts beforeContent afterContent, t) =
T.concat [beforeContent, t, afterContent]
@ -107,7 +105,7 @@ applyTemplate :: (TokenableTo Template a, TokenableTo Text b) => a -> b -> DepGe
applyTemplate a b = runFunction ApplyTemplate =<< toTupleToken a b
data ToText = ToText deriving (Show, Lift)
data ToText = ToText deriving Show
instance IsFunction ToText String Text where
evalFunction ToText (StringWrapper s) = T.pack s
@ -115,7 +113,7 @@ toText :: TokenableTo String a => a -> DepGenM (Token Text)
toText a = runFunction ToText =<< toToken a
data ConvertImage = ConvertImage deriving (Show, Lift)
data ConvertImage = ConvertImage deriving Show
instance IsFunction ConvertImage (Image, ImageConversionSettings) Image where
evalFunction ConvertImage (ImageWrapper image, ResizeToWidth widthResized) =
let sizeFactor :: Double
@ -127,7 +125,7 @@ convertImage :: (TokenableTo Image a, TokenableTo ImageConversionSettings b) =>
convertImage a b = runFunction ConvertImage =<< toTupleToken a b
data RunPandoc = RunPandoc deriving (Show, Lift)
data RunPandoc = RunPandoc deriving Show
instance IsFunction RunPandoc Text Text where
evalFunction RunPandoc contents =
let settings = P.def { P.readerExtensions = P.extensionsFromList [ P.Ext_raw_html ] }

17
byg/src/FunctionIO.hs
View File

@ -20,10 +20,9 @@ import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Codec.Picture as CP
import qualified System.Directory as SD
import Language.Haskell.TH.Syntax (Lift)
data ListDirectory = ListDirectory deriving (Show, Lift)
data ListDirectory = ListDirectory deriving Show
instance IsFunctionIO ListDirectory FilePath [FilePath] where
evalFunctionIO ListDirectory (StringWrapper s) =
map StringWrapper <$> SD.listDirectory s
@ -33,7 +32,7 @@ listDirectory :: TokenableTo FilePath a => a -> DepGenM (Token [FilePath])
listDirectory a = runFunctionIO ListDirectory =<< toToken a
data IsDirectory = IsDirectory deriving (Show, Lift)
data IsDirectory = IsDirectory deriving Show
instance IsFunctionIO IsDirectory FilePath Bool where
evalFunctionIO IsDirectory (StringWrapper s) =
SD.doesDirectoryExist s
@ -43,7 +42,7 @@ isDirectory :: TokenableTo FilePath a => a -> DepGenM (Token Bool)
isDirectory a = runFunctionIO IsDirectory =<< toToken a
data ReadTextFile = ReadTextFile deriving (Show, Lift)
data ReadTextFile = ReadTextFile deriving Show
instance IsFunctionIO ReadTextFile FilePath Text where
evalFunctionIO ReadTextFile (StringWrapper s) =
T.readFile s
@ -53,7 +52,7 @@ readTextFile :: TokenableTo FilePath a => a -> DepGenM (Token Text)
readTextFile a = runFunctionIO ReadTextFile =<< toToken a
data OpenImage = OpenImage deriving (Show, Lift)
data OpenImage = OpenImage deriving Show
instance IsFunctionIO OpenImage FilePath Image where
evalFunctionIO OpenImage (StringWrapper s) = do
imageOrig <- CP.readImage s
@ -66,7 +65,7 @@ openImage :: TokenableTo FilePath a => a -> DepGenM (Token Image)
openImage a = runFunctionIO OpenImage =<< toToken a
data SaveImage = SaveImage deriving (Show, Lift)
data SaveImage = SaveImage deriving Show
instance IsFunctionIO SaveImage (Image, FilePath) () where
evalFunctionIO SaveImage (ImageWrapper image, StringWrapper s) =
CP.saveJpgImage 90 s $ CP.ImageRGB8 image
@ -76,7 +75,7 @@ saveImage :: (TokenableTo Image a, TokenableTo FilePath b) => a -> b -> DepGenM
saveImage a b = runFunctionIO_ SaveImage =<< toTupleToken a b
data SaveTextFile = SaveTextFile deriving (Show, Lift)
data SaveTextFile = SaveTextFile deriving Show
instance IsFunctionIO SaveTextFile (Text, FilePath) () where
evalFunctionIO SaveTextFile (t, StringWrapper s) =
T.writeFile s t
@ -86,7 +85,7 @@ saveTextFile :: (TokenableTo Text a, TokenableTo FilePath b) => a -> b -> DepGen
saveTextFile a b = runFunctionIO_ SaveTextFile =<< toTupleToken a b
data CopyFile = CopyFile deriving (Show, Lift)
data CopyFile = CopyFile deriving Show
instance IsFunctionIO CopyFile (FilePath, FilePath) () where
evalFunctionIO CopyFile (StringWrapper source, StringWrapper target) =
SD.copyFile source target
@ -96,7 +95,7 @@ copyFile :: (TokenableTo FilePath a, TokenableTo FilePath b) => a -> b -> DepGen
copyFile a b = runFunctionIO_ CopyFile =<< toTupleToken a b
data MakeDir = MakeDir deriving (Show, Lift)
data MakeDir = MakeDir deriving Show
instance IsFunctionIO MakeDir FilePath () where
evalFunctionIO MakeDir (StringWrapper s) =
SD.createDirectory s

15
byg/src/Main.hs
View File

@ -1,28 +1,17 @@
{-# LANGUAGE TemplateHaskell #-}
module Main where
import DependencyGenerator (evalDepGenM)
import SiteGenerator (generateSite)
import qualified Precomputer
import System.Environment (getArgs)
import Data.Text (Text)
import qualified Data.Text.IO as T
import Language.Haskell.TH.Syntax
formatDependencyTrees :: Text
formatDependencyTrees = $$(Precomputer.formatDependencyTrees $(lift (evalDepGenM generateSite)))
runDeps :: IO ()
runDeps = $$(Precomputer.runDeps $(lift (evalDepGenM generateSite)))
main :: IO ()
main = do
args <- getArgs
case args of
["run"] ->
runDeps
$$(Precomputer.runDeps)
["tree"] ->
T.putStr formatDependencyTrees
$$(Precomputer.formatDependencyTrees)
_ ->
error "unexpected arguments"

13
byg/src/Precomputer.hs
View File

@ -4,15 +4,16 @@ module Precomputer
, formatDependencyTrees
) where
import Types.Dependency (Dependency)
import qualified DependencyRunner as DR
import qualified Types.Dependency as D
import SiteGenerator (generateSite)
import DependencyGenerator (evalDepGenM)
import Data.Text (Text)
import qualified Data.Text.IO as T
import Language.Haskell.TH.Syntax
runDeps :: [Dependency] -> Code Q (IO ())
runDeps deps = [|| DR.runDepRunMIO (DR.runDeps deps) ||]
runDeps :: Code Q (IO ())
runDeps = [|| DR.runDepRunMIO (DR.runDeps (evalDepGenM generateSite)) ||]
formatDependencyTrees :: [Dependency] -> Code Q Text
formatDependencyTrees deps = [|| D.formatDependencyTrees deps ||]
formatDependencyTrees :: Code Q (IO ())
formatDependencyTrees = [|| T.putStr (D.formatDependencyTrees (evalDepGenM generateSite)) ||]

6
byg/src/Types/Dependency.hs
View File

@ -17,7 +17,6 @@ import Types.FunctionIO (IsFunctionIO(..))
import Text.Printf (printf)
import Data.Text (Text)
import qualified Data.Text as T
import Language.Haskell.TH.Syntax (Lift)
data Action where
Function :: IsFunction f a b => f -> Action
@ -31,17 +30,16 @@ data Action where
MapComp :: [Dependency] -> UToken -> UToken -> Action
deriving instance Show Action
deriving instance Lift Action
data UToken = UToken Int
| UTupleToken UToken UToken
| UZipToken UToken UToken
| UListToken [UToken]
| UNoToken
deriving (Show, Lift)
deriving (Show)
data Dependency = Dependency UToken Action UToken
deriving (Show, Lift)
deriving (Show)
makeDependency :: Token a -> Action -> Token b -> Dependency
makeDependency a action b = Dependency (makeUToken a) action (makeUToken b)

4
byg/src/Types/Function.hs
View File

@ -5,7 +5,5 @@ module Types.Function
import Types.Value (Valuable)
import Language.Haskell.TH.Syntax (Lift)
class (Show f, Lift f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where
class (Show f, Valuable a, Valuable b) => IsFunction f a b | f -> a b where
evalFunction :: f -> a -> b

5
byg/src/Types/FunctionIO.hs
View File

@ -5,9 +5,6 @@ module Types.FunctionIO
import Types.Value (Valuable)
import Language.Haskell.TH.Syntax (Lift)
class (Show f, Lift f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where
class (Show f, Valuable a, Valuable b) => IsFunctionIO f a b | f -> a b where
evalFunctionIO :: f -> a -> IO b
functionIOTouchesFilesystem :: f -> Bool

3
byg/src/Types/Token.hs
View File

@ -3,8 +3,6 @@ module Types.Token
( Token(..)
) where
import Language.Haskell.TH.Syntax (Lift)
data Token a where
Token :: Int -> Token a
TupleToken :: Token a -> Token b -> Token (a, b)
@ -13,4 +11,3 @@ data Token a where
NoToken :: Token ()
deriving instance Show (Token a)
deriving instance Lift (Token a)

27
byg/src/Types/Value.hs
View File

@ -11,16 +11,11 @@ import Prelude hiding (String)
import Types.Values
import Data.Text (Text)
import Language.Haskell.TH.Syntax (Lift)
-- Note: We use a wrapper for the String type in order to be able to define the
-- general Valuable [a] instance further down. Otherwise it would conflict with
-- our Valuable String instance, since the non-wrapped String type is just an
-- alias for [Char].
--
-- Also note that the Image type does not actually implement Lift, so you
-- shouldn't use it with Inject. The better approach would be to split the
-- Value type into a compile-time version and a runtime version.
data Value = String String
| Text Text
| Bool Bool
@ -30,7 +25,7 @@ data Value = String String
| Empty
| Tuple (Value, Value)
| List [Value]
deriving (Eq, Show, Lift)
deriving (Eq, Show)
class Valuable a where
toValue :: a -> Value
@ -91,32 +86,32 @@ instance Valuable a => Valuable [a] where
_ -> error "unexpected"
class (Show w, Lift w) => WitnessFor w t | w -> t, t -> w where
class Show w => WitnessFor w t | w -> t, t -> w where
witnessValue :: w
data StringType = StringType deriving (Show, Lift)
data StringType = StringType deriving Show
instance WitnessFor StringType String where witnessValue = StringType
data TextType = TextType deriving (Show, Lift)
data TextType = TextType deriving Show
instance WitnessFor TextType Text where witnessValue = TextType
data BoolType = BoolType deriving (Show, Lift)
data BoolType = BoolType deriving Show
instance WitnessFor BoolType Bool where witnessValue = BoolType
data ImageType = ImageType deriving (Show, Lift)
data ImageType = ImageType deriving Show
instance WitnessFor ImageType Image where witnessValue = ImageType
data ImageConversionSettingsType = ImageConversionSettingsType deriving (Show, Lift)
data ImageConversionSettingsType = ImageConversionSettingsType deriving Show
instance WitnessFor ImageConversionSettingsType ImageConversionSettings where witnessValue = ImageConversionSettingsType
data TemplateType = TemplateType deriving (Show, Lift)
data TemplateType = TemplateType deriving Show
instance WitnessFor TemplateType Template where witnessValue = TemplateType
data EmptyType = EmptyType deriving (Show, Lift)
data EmptyType = EmptyType deriving Show
instance WitnessFor EmptyType () where witnessValue = EmptyType
data TupleType ta tb = TupleType ta tb deriving (Show, Lift)
data TupleType ta tb = TupleType ta tb deriving Show
instance (WitnessFor ta a, WitnessFor tb b) => WitnessFor (TupleType ta tb) (a, b) where witnessValue = TupleType witnessValue witnessValue
data ListType t = ListType t deriving (Show, Lift)
data ListType t = ListType t deriving Show
instance WitnessFor t a => WitnessFor (ListType t) [a] where witnessValue = ListType witnessValue

10
byg/src/Types/Values.hs
View File

@ -12,10 +12,9 @@ import qualified Prelude
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Codec.Picture as CP
import Language.Haskell.TH.Syntax (Lift(..))
newtype String = StringWrapper { unStringWrapper :: Prelude.String }
deriving (Eq, Lift)
deriving (Eq)
instance Show String where
show (StringWrapper s) = show s
@ -31,11 +30,8 @@ newtype Image = ImageWrapper (CP.Image CP.PixelRGB8)
instance Show Image where
show = const "Image"
instance Lift Image where
liftTyped _ = error "cannot lift images"
data ImageConversionSettings = ResizeToWidth Int
deriving (Eq, Show, Lift)
deriving (Eq, Show)
data Template = TemplateParts Text Text
deriving (Eq, Show, Lift)
deriving (Eq, Show)