1{-# LANGUAGE GADTs #-} 2module Spago.Dhall 3 ( module Spago.Dhall 4 , module Dhall 5 ) where 6 7import Spago.Prelude 8 9import qualified Control.Monad.Trans.State.Strict as State 10import qualified Data.Text as Text 11import qualified Data.Text.Prettyprint.Doc as Pretty 12import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText 13import Dhall 14import Dhall.Core as Dhall hiding (pretty) 15import qualified Dhall.Format 16import qualified Dhall.Import 17import qualified Dhall.Map 18import qualified Dhall.Parser as Parser 19import qualified Dhall.Pretty 20import Dhall.TypeCheck (typeOf) 21import Dhall.Util as Dhall 22import qualified Lens.Family 23import qualified System.FilePath as FilePath 24 25type DhallExpr a = Dhall.Expr Parser.Src a 26 27 28-- | Format a Dhall file in ASCII 29-- We first check if it's already formatted, if not we reformat it. 30format :: MonadIO m => Text -> m () 31format pathText = liftIO $ 32 try (f Dhall.Check) >>= \case 33 Left (_e :: SomeException) -> 34 f Dhall.Write 35 Right _ -> pure () 36 where 37 f = Dhall.Format.format 38 . Dhall.Format.Format 39 (Just Dhall.Pretty.ASCII) 40 Dhall.NoCensor 41 (Dhall.PossiblyTransitiveInputFile (Text.unpack pathText) Dhall.NonTransitive) 42 43 44-- | Prettyprint a Dhall expression adding a comment on top 45prettyWithHeader :: Pretty.Pretty a => Dhall.Header -> DhallExpr a -> Dhall.Text 46prettyWithHeader (Header header) expr = do 47 let doc = Pretty.pretty header <> Pretty.pretty expr 48 PrettyText.renderStrict $ Pretty.layoutSmart Pretty.defaultLayoutOptions doc 49 50data TemplateComments = WithComments | NoComments 51 52processComments :: TemplateComments -> Text -> Text 53processComments WithComments = id 54processComments NoComments = stripComments 55 56stripComments :: Text -> Text 57stripComments dhallSrc = 58 -- This is a hack taking advantage of current Dhall's parser behavior which does not preserve comments 59 -- This impl might need to be revisited after https://github.com/dhall-lang/dhall-haskell/issues/145 is fixed 60 case Parser.exprFromText mempty dhallSrc of 61 Left _ -> dhallSrc 62 Right expr -> pretty expr 63 64extractRecordValues 65 :: Dhall.Map.Map Text (Dhall.RecordField Parser.Src a) 66 -> Dhall.Map.Map Text (Dhall.Expr Parser.Src a) 67extractRecordValues = fmap (\Dhall.RecordField{..} -> recordFieldValue) 68 69-- | Return a list of all imports starting from a particular file 70readImports :: Text -> IO [Dhall.Import] 71readImports pathText = do 72 fileContents <- readTextFile $ pathFromText pathText 73 expr <- throws $ Parser.exprFromText mempty fileContents 74 status <- load expr 75 let graph = Lens.Family.view Dhall.Import.graph status 76 pure $ childImport <$> graph 77 where 78 load expr' 79 = State.execStateT 80 (Dhall.Import.loadWith expr') 81 (Dhall.Import.emptyStatus (FilePath.takeDirectory $ Text.unpack pathText)) 82 83 childImport 84 = Dhall.Import.chainedImport . Dhall.Import.child 85 86 87 88readRawExpr :: Text -> IO (Maybe (Dhall.Header, DhallExpr Dhall.Import)) 89readRawExpr pathText = do 90 exists <- testfile pathText 91 if exists 92 then (do 93 packageSetText <- readTextFile $ pathFromText pathText 94 fmap Just $ throws $ Parser.exprAndHeaderFromText mempty packageSetText) 95 else pure Nothing 96 97 98writeRawExpr :: Text -> (Dhall.Header, DhallExpr Dhall.Import) -> IO () 99writeRawExpr pathText (header, expr) = do 100 -- Verify that the package set exists 101 -- If Dhall gets a 404, it will throw a PrettyHttpException 102 resolvedExpr <- Dhall.Import.load expr 103 -- After modifying the expression, we have to check if it still typechecks 104 -- if it doesn't we don't write to file. 105 _ <- throws (Dhall.TypeCheck.typeOf resolvedExpr) 106 writeTextFile pathText $ prettyWithHeader header expr 107 format pathText 108 109 110-- | Returns a Dhall Text literal from a lone string 111toTextLit :: Text -> DhallExpr a 112toTextLit str = Dhall.TextLit (Dhall.Chunks [] str) 113 114 115-- | Casts a Dhall Text literal to a string, or fails 116fromTextLit 117 :: (Typeable a) 118 => DhallExpr a 119 -> Either (ReadError a) Text 120fromTextLit(Dhall.TextLit (Dhall.Chunks [] str)) = Right str 121fromTextLit expr = Left $ ExprIsNotTextLit expr 122 123 124-- | Require a key from a Dhall.Map, and run an action on it if found. 125-- If not found, return the name of the key. 126requireKey 127 :: (Typeable b, Pretty b, MonadThrow m) 128 => Dhall.Map.Map Text (DhallExpr b) 129 -> Text 130 -> (DhallExpr b -> m a) 131 -> m a 132requireKey ks name f = case Dhall.Map.lookup name ks of 133 Just v -> f v 134 Nothing -> throwM (RequiredKeyMissing name ks) 135 136 137-- | Same as `requireKey`, but we give it a Dhall.Decoder to automagically decode from 138requireTypedKey 139 :: (MonadIO m, MonadThrow m) 140 => Dhall.Map.Map Text (DhallExpr Void) 141 -> Text 142 -> Dhall.Decoder a 143 -> m a 144requireTypedKey ks name typ = requireKey ks name $ \expr -> case Dhall.extract typ expr of 145 Success v -> pure v 146 Failure _ -> throwM $ RequiredKeyMissing name ks 147 148-- | Try to find a key from a Dhall.Map, and automagically decode the value with the given Dhall.Type 149-- If not found, return `Nothing`, if type is incorrect throw error 150maybeTypedKey 151 :: (MonadIO m, MonadThrow m) 152 => Dhall.Map.Map Text (DhallExpr Void) 153 -> Text 154 -> Dhall.Decoder a 155 -> m (Maybe a) 156maybeTypedKey ks name typ = typify `mapM` Dhall.Map.lookup name ks 157 where 158 typify expr = case Dhall.extract typ expr of 159 Success v -> pure v 160 Failure a -> throwM a 161 162 163-- | Spago configuration cannot be read 164data ReadError a where 165 -- | the toplevel value is not a record 166 ConfigIsNotRecord :: Typeable a => DhallExpr a -> ReadError a 167 -- | the "packages" key is not a record 168 PackagesIsNotRecord :: Typeable a => DhallExpr a -> ReadError a 169 -- | the "dependencies" key is not a list 170 DependenciesIsNotList :: Typeable a => DhallExpr a -> ReadError a 171 -- | the expression is not a Text Literal 172 ExprIsNotTextLit :: Typeable a => DhallExpr a -> ReadError a 173 -- | the packages.dhall could not be parsed 174 CannotParsePackageSet :: Typeable a => DhallExpr a -> ReadError a 175 -- | the Import is not pointing to the right repo 176 ImportCannotBeUpdated :: Typeable a => Dhall.Import -> ReadError a 177 -- | a key is missing from a Dhall map 178 RequiredKeyMissing :: Typeable a => Text -> Dhall.Map.Map Text (DhallExpr a) -> ReadError a 179 180instance (Pretty a, Typeable a) => Exception (ReadError a) 181 182instance (Pretty a) => Show (ReadError a) where 183 show err = Text.unpack $ Text.intercalate "\n" $ 184 [ _ERROR <> ": Error while reading spago.dhall:" 185 , "" ] 186 <> msg err 187 188 where 189 msg :: ReadError a -> [Dhall.Text] 190 msg (PackagesIsNotRecord tl) = 191 [ "Explanation: The \"packages\" key must contain a record of packages." 192 , "" 193 , "The value was instead:" 194 , "" 195 , "↳ " <> pretty tl 196 ] 197 msg (DependenciesIsNotList e) = 198 [ "Explanation: The \"dependencies\" key must contain a list of package names." 199 , "" 200 , "The value was instead:" 201 , "" 202 , "↳ " <> pretty e 203 ] 204 msg (ConfigIsNotRecord tl) = 205 [ "Explanation: The config should be a record." 206 , "" 207 , "Its type is instead:" 208 , "" 209 , "↳ " <> pretty tl 210 ] 211 msg (RequiredKeyMissing key ks) = 212 [ "Explanation: a record is missing a required key." 213 , "" 214 , "The key missing is:" 215 , "" 216 , "↳ " <> key 217 , "" 218 , "The keys in the record are:" 219 , "" 220 , "↳ " <> (Text.intercalate ", " $ Dhall.Map.keys ks) 221 ] 222 msg (ExprIsNotTextLit e) = 223 [ "Explanation: the configuration contained a value that we expected to be" 224 , "a string, but wasn't." 225 , "" 226 , "The value was instead:" 227 , "" 228 , "↳ " <> pretty e 229 ] 230 msg (CannotParsePackageSet e) = 231 [ "Explanation: it was not possible to parse the `packages.dhall` file." 232 , "" 233 , "This is its Dhall expression:" 234 , "" 235 , "↳ " <> pretty e 236 ] 237 msg (ImportCannotBeUpdated imp) = 238 [ "Explanation: one of the imports in your `packages.dhall` file was not" 239 , "pointing to the purescript/package-sets repo, thus it couldn't be upgraded." 240 , "" 241 , "The import was:" 242 , "" 243 , "↳ " <> pretty (Dhall.Embed imp) 244 ] 245 246 _ERROR :: Dhall.Text 247 _ERROR = "\ESC[1;31mError\ESC[0m" 248